home *** CD-ROM | disk | FTP | other *** search
/ CD ROM Paradise Collection 4 / CD ROM Paradise Collection 4 1995 Nov.iso / program / tjgold.zip / INSTALL.001 / GOLDDB.PAS < prev    next >
Pascal/Delphi Source File  |  1995-07-12  |  74KB  |  2,449 lines
  1. {--------------------------------------------------------------------------}
  2. {                Product: TechnoJock's Turbo Toolkit                       }
  3. {                Version: GOLD                                             }
  4. {                Build:   1.01                                             }
  5. {                                                                          }
  6. {                Copyright 1986-1995  TechnoJock Software, Inc.            }
  7. {                           All Rights Reserved                            }
  8. {                          Restricted by License                           }
  9. {--------------------------------------------------------------------------}
  10.  
  11.                           {**********************}
  12.                           {**  Unit:   GOLDDB  **}
  13.                           {**********************}
  14.  
  15. {++++++++++++++++++++++++++++++} unit GOLDDB; {++++++++++++++++++++++++++++}
  16.  
  17. {$I GOLDFLAG.INC}
  18. {$IFNDEF GOLDDB}
  19.    {$DEFINE GOLDDB}
  20. {$ENDIF}
  21.  
  22. {++++++++++++++++++++++++++++++++} INTERFACE {+++++++++++++++++++++++++++++}
  23.  
  24. uses DOS, CRT, Goldwin, GoldHard, GoldMisc, GoldKey, GoldFast, DFBtree,
  25.      DFPage, GoldLink, DFBtreUT, GoldStr, GoldReal, GoldDate, GoldMemo,
  26.      GoldList;
  27.  
  28. const
  29.    EOH: byte = $0D;
  30.    EOFile: byte = $1A;
  31.    EOM: byte = $1A;
  32.    Space: byte = $20;
  33.    Astk: byte = $2A;
  34.    MaxRecLen = 4000;
  35.    MaxNdxLen = 245;
  36.    DFX = '.DBF';     { data file extension }
  37.    IFX = '.GDX';     { index file extension }
  38.    MFX = '.DBT';     { memo file extension }
  39.    MaxNdxStrLen: byte = 30;
  40.    MemoPageSize = 512;
  41.    DbTempFname:string[12] = 'delete.me';
  42.  
  43. type
  44.    ShowNdxProgressProc = procedure( KeysWritten, TotRecords: longint; Status: byte );
  45.  
  46.    HeaderPtr  = ^HeaderInfo;
  47.    HeaderInfo = record
  48.       VersionNumber: byte;
  49.       Update: array [1..3] of byte;
  50.       NbrRec: longint;
  51.       HdrLen: integer;
  52.       RecLen: integer;
  53.       Reserved: array [1..20] of char;
  54.    end;
  55.  
  56.    FieldPtr = ^FieldDesc;
  57.    FieldDesc = record
  58.       FdName: array [1..11] of char;
  59.       FdType: char;
  60.       Reserved1: array [1..4] of char;
  61.       FdLength: byte;
  62.       FdDec: byte;
  63.       Reserved2: array [1..14] of char;
  64.    end;
  65.  
  66.    MemoPtr = ^MemoDesc;
  67.    MemoDesc = record
  68.       NextMemoRec: longint;
  69.       LastMemoRec: longint;
  70.       EmptySpace: array [1..508] of char;
  71.    end;
  72.  
  73.    GdbBaseWrkSpc = array [1..MaxRecLen] of char;
  74.    GdbNdxWrkSpc = array [1..MaxNdxLen] of char;
  75.    WrkSpcPtr = ^GdbBaseWrkSpc;
  76.    NdxSpcPtr = ^GdbNdxWrkSpc;
  77.  
  78.    DBStatus = record  { information pertaining to DataSet }
  79.       DbtAlias: file;
  80.       NdxAlias: file;
  81.       DbfAlias: file;
  82.       DBPath: PathStr;
  83.       DbtName: PathStr;
  84.       NdxName: PathStr;
  85.       DbfName: PathStr;
  86.       SaveIndexFldValue: boolean;
  87.       DeletingIndexEntry: boolean;
  88.       DFOpen: boolean;
  89.       MFOpen: boolean;
  90.       vHdrModified: boolean;
  91.       MemoIsIncluded: boolean;
  92.       RecStatus: byte;
  93.       IndexField: integer;
  94.       NdxFldLen: integer;
  95.       IndexUpperCase: boolean;
  96.       pHead: HeaderPtr;
  97.       pField: FieldPtr;
  98.       pMemo: MemoPtr;
  99.       FldInfo: SingleLL;
  100.       WrkSpc: WrkSpcPtr;
  101.       NdxSpc: NdxSpcPtr;
  102.       BakNdxSpc: NdxSpcPtr;
  103.       Fpos: longint;
  104.       CurrentRec: longInt;
  105.    end;
  106.  
  107.    DBListNodePtr = ^DBListNode;
  108.    DBListNode = record
  109.       DBInfo: DBStatus;
  110.       NextPtr: DBListNodePtr;
  111.    end;
  112.  
  113.    DBSet = record  { global information }
  114.       DbfCFld,
  115.       DbfNFld,
  116.       DbfLFld,
  117.       DbfDFld,
  118.       DbfMFld: char;
  119.       HasMemo,
  120.       ClosingAll,
  121.       FldLstIsActive,
  122.       FullStrings,
  123.       Packing: boolean;
  124.       MemoSize,
  125.       LastECode: integer;
  126.       EMsgFunc: ErrMsgFunc;
  127.       ShowNdxProgress: ShowNdxProgressProc;
  128.       DbfFieldList: SingleLL;
  129.       StartNode: DBListNodePtr;
  130.       ActiveNode: DBListNodePtr;
  131.       DBsOpen: integer;
  132.       Actual: word;
  133.    end;
  134.  
  135. {dbf procs}
  136. function  DbOpenDataSet(DBFile: pathstr): integer;
  137. procedure DbSetActiveDataBase(Handle:integer);
  138. function  LastDBError: integer;
  139. function  DBFExist(FN: PathStr): boolean;
  140. function  DbGetVersion: byte;
  141. function  DbGetUpDate: dates;
  142. procedure DbPutUpDate;
  143. function  DbTotalFields: integer;
  144. function  DbGetNumRecs: longint;
  145. function  DbCurrRecNum: longint;
  146. function  DbGetHdrLen: integer;
  147. function  DbGetRecLen: word;
  148. function  DbRecordIsActive(RecNo: longint): boolean;
  149. procedure DbSetFullStrings(On: boolean);
  150. function  DbGetFldName(FieldNo: integer): string;
  151. function  DbGetFldType(FieldNo: integer): char;
  152. function  DbGetFldLength(FieldNo: integer): integer;
  153. function  DbGetFldDec(FieldNo: integer): integer;
  154. function  DbIndexedField: integer;
  155. function  DbGetFldString(RecNo: longint; FieldNo: integer): string;
  156. function  DbGetFldInt(RecNo: longint; FieldNo: integer): integer;
  157. function  DbGetFldLong(RecNo: longint; FieldNo: integer): longint;
  158. function  DbGetFldReal(RecNo: longint; FieldNo: integer): extended;
  159. function  DbGetFldLogical(RecNo: longint; FieldNo: integer): boolean;
  160. procedure DbGetFldMemo(RecNo: longint; FieldNo: integer;var MemoDetails:MemoCfg);
  161. function  DbGetMemoRecNum(RecNo:longint;FieldNo:integer):longint;
  162. function  DbSetFldMemo(FldNo: integer;var SL: SingleLL): longint;
  163. function  DbGetFldDate(RecNo: longint; FieldNo: integer): Dates;
  164. procedure DbSetFldString(FieldNo: integer; StrVar: string);
  165. procedure DbSetFldInt(FieldNo: integer; IntVar: longint);
  166. procedure DbSetFldReal(FieldNo: integer; RealVar: Extended);
  167. procedure DbSetFldLogical(FieldNo: integer; BoolVar: boolean);
  168. procedure DbSetFldDate(FieldNo: integer; DateVar: longint);
  169. function  DbFldIsEmpty(RecNo: longint;FieldNo: integer):boolean;
  170. procedure DbClearWrkSpc;
  171. procedure DbPutHeader(var Alias: file);
  172. procedure DbAddRecord;
  173. procedure DbDeleteRecord(RecNo: longint);
  174. procedure DbUnDeleteRecord(RecNo: longint);
  175. procedure DbGetRecord(RecNo: longint);
  176. procedure DbPutRecord;
  177. function  DbSeqSearch(var RecNo: longint; FieldNo: integer; SearchTxt: String): boolean;
  178. function  DbPackFile(FName: PathStr; IndexField: integer): integer;
  179. procedure DbCloseDataBase(Handle: integer);
  180. procedure DbCloseAllDatabases;
  181. {dbf creation procs}
  182. function  DbAddDbfField(FldName: string; FldType: char; FldLen, FldDecPl: integer): integer;
  183. function  DbBuildDataFile( FN: Pathstr; NDXFld : byte): integer;
  184. procedure DbBuildMemoFile(FName:PathStr);
  185. function  DbRebuildMemo(FName: PathStr): integer;
  186. function  DbFindFirst(FieldNo: integer; var findValue; PartialMatch: boolean): longint;
  187. function  DbFindNext: longInt;
  188. {ndx procs}
  189. procedure SetShowNdxProgress(Proc: ShowNdxProgressProc);
  190. function  NdxGotoFirst: longint;
  191. function  NdxGotoLast: longint;
  192. function  NdxGotoNext: longint;
  193. function  NdxGotoPrev: longint;
  194. function  NdxValidate(Partial: boolean): byte;
  195. function  NdxRebuild: integer;
  196. function  NdxBuildNew(FieldNo: integer): integer;
  197. function  NdxGetRecNum(EntryNum: longInt) : longInt;
  198. procedure NdxSetMaxPages(n: Word);
  199. procedure NdxSetUpperCase(x: boolean);
  200. procedure NdxSetMaxStrLength(n: Byte);
  201. function  NdxCount : longint;
  202.  
  203. var
  204.    DbVars: DBSet;
  205.  
  206. {+++++++++++++++++++++++++++++} IMPLEMENTATION {+++++++++++++++++++++++++++++}
  207.  
  208.                     {**********************************}
  209.                     {**    Miscellaneous Routines    **}
  210.                     {**********************************}
  211.  
  212. {$IFOPT F-}
  213.    {$DEFINE FOFF}
  214.    {$F+}
  215. {$ENDIF}
  216. function DbEMsg(ECode:integer): string;
  217. {}
  218. begin
  219.    case Ecode of
  220.       2   : DbEMsg := 'File was not found in current directory';
  221.       4   : DbEMsg := 'Too many open files';
  222.       8   : DbEMsg := 'Insufficient memory for allocation';
  223.       100 : DbEMsg := 'Unable to read from media';
  224.       101 : DbEMsg := 'Unable to write to file';
  225.       102 : DbEMsg := 'Assign must be called first';
  226.       103 : DbEMsg := 'File has not been successfully opened';
  227.       104 : DbEMsg := 'File must be opened for input first';
  228.       105 : DbEMsg := 'File must be opened for output first';
  229.       106 : DbEMsg := 'An invalid numeric format has been encountered';
  230.       150 : DbEMsg := 'Disk is write protected';
  231.       151 : DbEMsg := 'Unknown unit';
  232.       152 : DbEMsg := 'Drive not ready';
  233.       153 : DbEMsg := 'Unknown command';
  234.       154 : DbEMsg := 'CRC error in data';
  235.       155 : DbEMsg := 'Bad drive request structure length';
  236.       156 : DbEMsg := 'Disk seek error';
  237.       157 : DbEMsg := 'Unknown media type';
  238.       158 : DbEMsg := 'Sector not found';
  239.       159 : DbEMsg := 'Printer out of paper';
  240.       160 : DbEMsg := 'Device write fault';
  241.       161 : DbEMsg := 'Device read fault';
  242.       162 : DbEMsg := 'Hardware failure';
  243.       900..999 : { close file errors }
  244.             DbEMsg := 'Close failure';
  245.       1000: DbEMsg := 'Number of fields cannot exceed 127';
  246.       1001: DbEMsg := 'Nothing to do';
  247.       1002: DbEMsg := 'Value must be >= current value contained in pHead^.NbrRec';
  248.       1003: DbEMsg := 'Invalid value, Header Length';
  249.       1004: DbEMsg := 'Record Length must be greater than zero';
  250.       1005: DbEMsg := 'Invalid Field Name, could not be set';
  251.       1006: DbEMsg := 'Field type invalid, Field type not set';
  252.       1007: DbEMsg := 'Field length is out of range, unable to set';
  253.       1008: DbEMsg := 'No records available';
  254.       1009: DbEMsg := 'Insufficient heap available to move header';
  255.       1010: DbEMsg := 'Not a valid dbf file or file is corrupted';
  256.       1012: DbEMsg := 'Field type must be ''N'' for decimals to be greater than zero';
  257.       1013: DbEMsg := 'Unable to get record';
  258.       1014: DbEMsg := 'Unable to delete record';
  259.       1015: DbEMsg := 'Unable to undelete record';
  260.       1016: DbEMsg := 'Unable to determine record status';
  261.       1017: DbEMsg := 'Error in key string';
  262.       1018: DbEMsg := 'Memo file already exists';
  263.       1019: DbEMsg := 'Cannot activate database; closed or inactive handle';
  264.       1020: DbEMsg := 'Insufficient heap available to init Database';
  265.       1021: DbEMsg := 'Unable to locate DBF (data) file';
  266.       1022: DbEMsg := 'Unable to locate NDX (index) file';
  267.       1023: DbEMsg := 'Unable to locate DBT (memo) file';
  268.       1024: DbEMsg := 'Not enough memory to create DBF Header';
  269.       1025: DbEMsg := 'Error building field list from header';
  270.       1026: DbEMsg := 'Field is not a String field';
  271.       1027: DbEMsg := 'Field is not a Numeric field';
  272.       1028: DbEMsg := 'Field is not a Boolean field';
  273.       1029: DbEMsg := 'Field is not a Memo field';
  274.       1030: DbEMsg := 'InValid function call, Memo field not included';
  275.       1031: DbEMsg := 'Field is not a Date field';
  276.       1032: DbEMsg := 'Record number is out-of-range';
  277.       1033: DbEMsg := 'Error building new memo file';
  278.       1034: DbEMsg := 'Unable to open memo file';
  279.       1035: DbEMsg := 'DBT corrupt';
  280.       1036: DbEMsg := 'Error resetting DBT file to access memo';
  281.       1037: DbEMsg := 'Error writing memo to DBT file';
  282.       1038: DbEMsg := 'Unable to create DBT';
  283.       1039: DbEMsg := 'Unable to create DBF file';
  284.       1052: DbEMsg := 'Field Number is out-of-range';
  285.       1067: DbEMsg := 'Memo''s can only be read into SLL assigned MemoCFG''s';
  286.       1085: DbEMsg := 'Index rebuild failure during pack, potential corruption';
  287.       1086: DbEMsg := 'Unable to create datafile; no fields defined';
  288.       1087: DbEMsg := 'Unable to delete index file';
  289.       1088: DbEMsg := 'Error rebuilding memo file';
  290.       1101..1150 : { read errors }
  291.             DbEMsg := 'Read Error, '+IntToStr(ECode);
  292.       1151..1200 : { write errors }
  293.             DbEMsg := 'Write Error, '+IntToStr(ECode);
  294.       1201..1250 : { seek errors }
  295.             DbEMsg := 'Seek Error, '+IntToStr(ECode);
  296.       1251..1300 : { reset errors }
  297.             DbEMsg := 'Reset Error, '+IntToStr(ECode);
  298.       1301..1350 : { rewrite errors }
  299.             DbEMsg := 'Rewrite Error, '+IntToStr(ECode);
  300.       2000: DbEMsg := 'Unable to open index file';
  301.       2001: DbEMsg := 'Not a valid index file';
  302.       else
  303.          DbEMsg := 'Internal database error';
  304.    end; {case}
  305. end; { DbEMsg }
  306.  
  307. procedure NoProgressHook( KeysWritten,Records: longint; Status:byte);
  308. { empty proc }
  309. begin
  310.    {abstract}
  311. end; { NoProgressHook }
  312.  
  313. {$IFDEF FOFF}
  314.    {$F-}
  315.    {$UNDEF FOFF}
  316. {$ENDIF}
  317.  
  318. procedure DBSetError(ECode:integer);
  319. {}
  320. {$IFOPT D+}
  321. var Msg: StrScreen;
  322. {$ENDIF}
  323. begin
  324.    DbVars.LastEcode := ECode;
  325. {$IFOPT D+}  {if debug active display an error message and terminate}
  326.    if Ecode <> 0 then
  327.    begin
  328.       str(Ecode,Msg);
  329.       Msg := Msg+': '+DBVars.EMsgFunc(Ecode);
  330.       SetWinIgnore(true);
  331.       if PromptCustom(' GoldDB Error ',Msg,' ~I~gnore ',' ~A~bort ','',279,286,0,0, 10000) = 2 then
  332.          Halt;
  333.    end;
  334. {$ENDIF}
  335. end; { DBSetError }
  336.  
  337. procedure AllocateNdxSpc;
  338. {}
  339. begin
  340.    with DbVars.ActiveNode^.DBInfo do
  341.    begin
  342.       if IndexField > 0 then
  343.       begin
  344.          getmem(NdxSpc,NdxFldLen);
  345.          getmem(BakNdxSpc,NdxFldLen);
  346.       end;
  347.    end;
  348. end; { AllocateNdxSpc }
  349.  
  350. {$I GoldNDX.INC}
  351.  
  352. function SizeOfData: longint;
  353. {}
  354. begin
  355.    SizeOfData :=  ( sizeof(DBListNode) +        {  766 }
  356.                     sizeof(HeaderInfo) +        {   32 }
  357.                     sizeof(FieldDesc) +         {   32 }
  358.                     sizeof(MemoDesc) +          {  516 }
  359.                     sizeof(GdbBaseWrkSpc) +     { 4000 }
  360.                    (sizeof(GdbNdxWrkSpc)*2));   {  490 }  {=} { 5836 }
  361. end;
  362.  
  363. function DbInitDatabase: integer;
  364. {Returns the DB ID of the newly opened database or 0 if failed}
  365. var
  366.    Temp: DBListNodePtr;
  367.    ID:word;
  368. begin
  369.    DbInitDataBase := 0;
  370.    if GoldMaxAvail < SizeOfData then
  371.       DBSetError(1020) { Insufficient heap available to init Database }
  372.    else
  373.    begin
  374.       if DbVars.StartNode = nil then
  375.       begin
  376.          getmem(DbVars.StartNode,sizeof(DbVars.StartNode^));
  377.          Temp := DbVars.StartNode;
  378.          ID := 1;
  379.       end else
  380.       begin
  381.          Temp := DbVars.StartNode;
  382.          ID := 1;
  383.          while Temp^.NextPtr <> nil do
  384.          begin
  385.             Temp := Temp^.NextPtr;
  386.             inc(ID);
  387.          end;
  388.          getmem(Temp^.NextPtr, sizeof(Temp^.NextPtr^));
  389.          inc(ID);
  390.          Temp := Temp^.NextPtr;
  391.       end;
  392.       Temp^.NextPtr := nil;
  393.       with Temp^.DBInfo do
  394.       begin    { initialize DB stuff }
  395.          fillchar(Temp^.DBInfo,sizeof(Temp^.DBInfo),#0);
  396.          SaveIndexFldValue := true;
  397.          getmem(pHead,sizeof(pHead^));
  398.          getmem(pField,sizeof(pField^));
  399.       end;
  400.       DbVars.ActiveNode := Temp;
  401.       DbInitDataBase := ID;
  402.       inc(DbVars.DBsOpen);
  403.    end;
  404. end; { DbInitDataBase }
  405.  
  406. procedure DbSetActiveDataBase(Handle:integer);
  407. {}
  408. var
  409.    Temp: DBListNodePtr;
  410.    I: integer;
  411. begin
  412.    if ( Handle > 0 ) then
  413.    with DbVars do
  414.    begin
  415.       Temp := ActiveNode;
  416.       ActiveNode :=  StartNode;
  417.       for I := 2 to Handle do
  418.       begin
  419.          if DbVars.ActiveNode <> nil then
  420.             ActiveNode := ActiveNode^.NextPtr;
  421.       end;
  422.       if (ActiveNode = nil) or ( not ActiveNode^.DBInfo.DFOpen ) then
  423.       begin
  424.          ActiveNode := Temp;  { No change }
  425.          DBSetError(1019);  { Cannot activate database; closed or inactive handle }
  426.       end;
  427.    end;
  428. end; { DbSetActiveDataBase }
  429.  
  430. function LastDBError: integer;
  431. {}
  432. begin
  433.    LastDBError := DbVars.LastEcode;
  434.    DbSetError(0); { clear LastEcode }
  435. end; { LastDBError }
  436.  
  437. function DBFExist(FN: PathStr): boolean;
  438. {}
  439. var Drv: string[1];
  440.     FullStr, Pth: PathStr;
  441.     Name: string[8];
  442.     SR: SearchRec;
  443. begin
  444.    Drv := FileDrive(FN);
  445.    Pth := FileDirectory(FN);
  446.    Name := FileName(FN);
  447.    if Drv <> '' then
  448.       Drv := Drv + ':';
  449.    if Pth <> '' then
  450.       FullStr :=  Drv + SlashedDirectory(Pth) + Name + DFX
  451.    else
  452.       FullStr := Drv + Name + DFX;
  453.    FindFirst(FullStr,Anyfile-Hidden-Directory-SysFile-VolumeID,SR);
  454.    DBFExist := DosError = 0;
  455. end; { DBFExist }
  456.  
  457. function DbGetVersion: byte;
  458. {}
  459. begin
  460. {$IFDEF CHECK}
  461.    if DBVARS.ActiveNode = nil then
  462.       DbSetError(103);
  463. {$ENDIF}
  464.    with DbVars.ActiveNode^.DBInfo.pHead^ do
  465.       DbGetVersion := VersionNumber;
  466. end; { DbGetVersion }
  467.  
  468. function DbGetUpDate: dates;
  469. { Date is in the form of YY MM DD }
  470. var
  471.   TmpByte: array[1..3] of byte;
  472. begin
  473. {$IFDEF CHECK}
  474.    if DBVARS.ActiveNode = nil then
  475.       DbSetError(103);
  476. {$ENDIF}
  477.    with DbVars.ActiveNode^.DBInfo.pHead^ do
  478.    begin
  479.       move(UpDate,TmpByte,sizeof(TmpByte));
  480.       DBgetUpdate := GregToJul(TmpByte[2],TmpByte[3],1900+TmpByte[1]);
  481.    end;
  482. end; { DbGetUpDate }
  483.  
  484. procedure DbPutUpDate;
  485. {Date of most recent change to file}
  486. var vYear,vMth,vDay,vDow: word;
  487. begin
  488. {$IFDEF CHECK}
  489.    if DBVARS.ActiveNode = nil then
  490.       DbSetError(103);
  491. {$ENDIF}
  492.    with DbVars.ActiveNode^.DBInfo do
  493.    begin
  494.       getdate(vYear,vMth,vDay,vDow);  { Current System Date }
  495.       pHead^.Update[1] := vYear-1900;
  496.       pHead^.Update[2] := vMth;
  497.       pHead^.Update[3] := vDay;
  498.       vHdrModified := true;
  499.    end;
  500. end; { DbPutUpDate }
  501.  
  502. function DbTotalFields: integer;
  503. {}
  504. begin
  505. {$IFDEF CHECK}
  506.    if DBVARS.ActiveNode = nil then
  507.       DbSetError(103);
  508. {$ENDIF}
  509.    with DbVars.ActiveNode^ do
  510.       DbTotalFields := ( DbGetHdrLen - 33 ) div 32;
  511. end; { DbTotalFields }
  512.  
  513. function DbGetNumRecs: longint;
  514. {}
  515. begin
  516.    {$IFDEF CHECK}
  517.    if DBVARS.ActiveNode = nil then
  518.       DbSetError(103);
  519.    {$ENDIF}
  520.    with DbVars.ActiveNode^.DBInfo.pHead^ do
  521.       DbGetNumRecs := NbrRec;
  522. end; { DbGetNumRecs }
  523.  
  524. function DbCurrRecNum: longint;
  525. {}
  526. begin
  527. {$IFDEF CHECK}
  528.    if DBVARS.ActiveNode = nil then
  529.       DbSetError(103);
  530. {$ENDIF}
  531.    with DbVars.ActiveNode^.DBInfo do
  532.       DbCurrRecNum := CurrentRec;
  533. end; { DbCurrRecNum }
  534.  
  535. function DbGetMemoRecNum(RecNo:longint;FieldNo:integer):longint;
  536. {}
  537. begin
  538. {$IFDEF CHECK}
  539.    if DBVARS.ActiveNode = nil then
  540.       DbSetError(103);
  541. {$ENDIF}
  542.    with DbVars.ActiveNode^.DBInfo do
  543.       DbGetMemoRecNum := DbGetFldLong(RecNo,FieldNo);
  544. end; { DbGetMemoRecNum }
  545.  
  546. procedure DbPutNumRecs(Amount: longint);
  547. {internal}
  548. begin
  549. {$IFDEF CHECK}
  550.    if DBVARS.ActiveNode = nil then
  551.       DbSetError(103);
  552. {$ENDIF}
  553.    with DbVars.ActiveNode^.DBInfo do
  554.    begin
  555.       if ( Amount > DbGetNumRecs ) or DbVars.Packing then
  556.       begin
  557.          pHead^.NbrRec := Amount;
  558.          vHdrModified := true;
  559.       end else
  560.          DBSetError(1002);
  561.    end;
  562. end; { DbPutNumRecs }
  563.  
  564. function DbGetHdrLen: integer;
  565. {}
  566. begin
  567. {$IFDEF CHECK}
  568.    if DBVARS.ActiveNode = nil then
  569.       DbSetError(103);
  570. {$ENDIF}
  571.    with DbVars.ActiveNode^.DBInfo do
  572.       DbGetHdrLen := pHead^.HdrLen;
  573. end; { DbGetHdrLen }
  574.  
  575. function DbGetRecLen: word;
  576. {}
  577. begin
  578. {$IFDEF CHECK}
  579.    if DBVARS.ActiveNode = nil then
  580.       DbSetError(103);
  581. {$ENDIF}
  582.    with DbVars.ActiveNode^.DBInfo do
  583.       DbGetRecLen := pHead^.RecLen;
  584. end; { DbGetRecLen }
  585.  
  586. function RecIsWithinRange(RecNo: longint): boolean;
  587. {}
  588. begin
  589.    RecIsWithinRange := ((RecNo >= 1) and (RecNo <= DbGetNumRecs));
  590. end; { RecIsWithinRange }
  591.  
  592. function FldIsWithinRange(FieldNo: integer): boolean;
  593. {}
  594. begin
  595.    FldIsWithinRange := ((FieldNo >= 1) and (FieldNo <= DbTotalFields));
  596. end; { FldIsWithinRange }
  597.  
  598. function DbRecordIsActive( RecNo: longint ): Boolean;
  599. {}
  600. var TmpB: boolean;
  601. begin
  602.    DbRecordIsActive := false;
  603. {$IFDEF CHECK}
  604.    if DBVARS.ActiveNode = nil then
  605.       DbSetError(103);
  606. {$ENDIF}
  607.    with DbVars.ActiveNode^.DBInfo do
  608.    begin
  609.       if RecIsWithinRange(RecNo) then
  610.       begin
  611.          if RecNo <> CurrentRec then
  612.             DbGetRecord(RecNo);
  613.          case WrkSpc^[1] of
  614.             ' ' : TmpB := true;
  615.             '*' : TmpB := false;
  616.             else
  617.             DBSetError(1016); { Unable to determine record status }
  618.          end;
  619.       end;
  620.    end;
  621.    DbRecordIsActive := TmpB;
  622. end; { DbRecordIsActive }
  623.  
  624. procedure DbSetFullStrings(On: boolean);
  625. {}
  626. begin
  627.    DbVars.FullStrings := On;
  628. end; { DbSetFullStrings }
  629.  
  630. function DbGetFldName( FieldNo: integer ): string;
  631. {}
  632. var TempStr: string;
  633. begin
  634. {$IFDEF CHECK}
  635.    if DBVARS.ActiveNode = nil then
  636.       DbSetError(103);
  637. {$ENDIF}
  638.    with DbVars.ActiveNode^ do
  639.    begin
  640.       TempStr := _SLLGetNodeStr(DbInfo.FldInfo,_SLLNodePtr(DbInfo.FldInfo,FieldNo),255);
  641.       DbGetFldName := copy(TempStr,1,pred(pos(#0,TempStr)));
  642.    end;
  643. end; { DbGetFldName }
  644.  
  645. function DbGetFldType( FieldNo: integer ): char;
  646. {}
  647. var Ch: string[1];
  648. begin
  649. {$IFDEF CHECK}
  650.    if DBVARS.ActiveNode = nil then
  651.       DbSetError(103);
  652. {$ENDIF}
  653.    with DbVars.ActiveNode^ do
  654.       Ch := copy(_SLLGetNodeStr(DbInfo.FldInfo,_SLLNodePtr(DBInfo.FldInfo,FieldNo),255),12,1);
  655.    DbGetFldType := ch[1];
  656. end; { DbGetFldType }
  657.  
  658. function DbGetFldLength( FieldNo: integer ): integer;
  659. {}
  660. var TempStr: string;
  661. begin
  662. {$IFDEF CHECK}
  663.    if DBVARS.ActiveNode = nil then
  664.       DbSetError(103);
  665. {$ENDIF}
  666.    with DbVars.ActiveNode^ do
  667.    begin
  668.       {$IFDEF CHECK}
  669.       if (FieldNo < 1) or (FieldNo > DbTotalFields) then
  670.       begin
  671.          DbSetError(1052); { FieldNo is out-of-range }
  672.          DbGetFldLength := 0;
  673.       end;
  674.       {$ENDIF}
  675.       TempStr := _SLLGetNodeStr(DBInfo.FldInfo,_SLLNodePtr(DBInfo.FldInfo,FieldNo),255);
  676.       DbGetFldLength := integer(TempStr[17]); { length byte }
  677.    end;
  678. end; { DbGetFldLength }
  679.  
  680. function DbGetFldDec( FieldNo: Integer ): integer;
  681. {}
  682. var TempStr: string;
  683. begin
  684. {$IFDEF CHECK}
  685.    if DBVARS.ActiveNode = nil then
  686.       DbSetError(103);
  687. {$ENDIF}
  688.    with DbVars.ActiveNode^ do
  689.    begin
  690.       TempStr := _SLLGetNodeStr(DBInfo.FldInfo,_SLLNodePtr(DBInfo.FldInfo,FieldNo),255);
  691.       DbGetFldDec := integer(TempStr[18]);    { decimal byte }
  692.    end;
  693. end; { DbGetFldDec }
  694.  
  695. function StrtPos(FieldNo: integer): integer;
  696. {}
  697. var TmpPos, I: integer;
  698. begin
  699. {$IFDEF CHECK}
  700.    if DBVARS.ActiveNode = nil then
  701.       DbSetError(103);
  702. {$ENDIF}
  703.    with DbVars.ActiveNode^.DBInfo do
  704.    begin
  705.       TmpPos := 2; { must account for status byte + 1 }
  706.       if FieldNo <> 1 then
  707.          for I := pred(FieldNo) downto 1 do
  708.             inc(TmpPos,DbGetFldLength(I));
  709.       StrtPos := TmpPos;
  710.    end;
  711. end; { StrtPos }
  712.  
  713. procedure BakUpNdxSpc;
  714. {}
  715. begin
  716. {$IFDEF CHECK}
  717.    if DBVARS.ActiveNode = nil then
  718.       DbSetError(103);
  719. {$ENDIF}
  720.    with DbVars.ActiveNode^.DBInfo do
  721.    if (NdxSpc <> nil) and (BakNdxSpc <> nil) then
  722.       move(NdxSpc^,BakNdxSpc^,NdxFldLen);
  723. end; { BakUpNdxSpc }
  724.  
  725. function GetField(RecNo: longint; FieldNo: integer): string;
  726. {internal}
  727. var Len: integer;
  728.     TempStr: string;
  729. begin
  730. {$IFDEF CHECK}
  731.    if DBVARS.ActiveNode = nil then
  732.       DbSetError(103);
  733. {$ENDIF}
  734.    with DbVars.ActiveNode^.DBInfo do
  735.    begin
  736.       GetField := '';
  737.       if (FieldNo = IndexField) and (DeletingIndexEntry) then
  738.       begin
  739.          move(BakNdxSpc^,TempStr[1],NdxFldLen);
  740.          TempStr[0] := chr(NdxFldLen);
  741.          GetField := TempStr;
  742.       end
  743.       else if RecIsWithinRange(RecNo) then
  744.       begin
  745.          if FldIsWithinRange(FieldNo) then
  746.          begin
  747.             if (RecNo <> CurrentRec) then
  748.                DbGetRecord(RecNo);
  749.             Len := DbGetFldLength(FieldNo);
  750.             move(WrkSpc^[StrtPos(FieldNo)],TempStr[1],Len);
  751.             TempStr[0] := chr(Len);
  752.             GetField := TempStr;
  753.             if NdxSpc = nil then
  754.                AllocateNdxSpc;
  755.             if FieldNo = IndexField then
  756.                move(TempStr[1],NdxSpc^,NdxFldLen);
  757.          end
  758.          else
  759.             DBSetError(1052); { Field number out-of-range }
  760.       end
  761.       else
  762.          DBSetError(1032); { Record Number out-of-range }
  763.    end;
  764. end; { GetField }
  765.  
  766. function DbIndexFieldChanged: boolean;
  767. {}
  768. begin
  769. {$IFDEF CHECK}
  770.    if DBVARS.ActiveNode = nil then
  771.       DbSetError(103);
  772. {$ENDIF}
  773.    with DbVars.ActiveNode^.DBInfo do
  774.       DbIndexFieldChanged := Different(NdxSpc^,WrkSpc^[StrtPos(IndexField)],NdxFldLen);
  775. end; { DbIndexFieldChanged }
  776.  
  777. function DbIndexedField: integer;
  778. {}
  779. begin
  780.    with DbVars.ActiveNode^.DBInfo do
  781.       DbIndexedField := IndexField;
  782. end; { DbIndexedField }
  783.  
  784. function DbGetFldString(RecNo: longint; FieldNo: integer): string;
  785. {}
  786. var TmpStr: string;
  787.     Len: integer;
  788. begin
  789. {$IFDEF CHECK}
  790.    if DBVARS.ActiveNode = nil then
  791.       DbSetError(103);
  792. {$ENDIF}
  793.    with DbVars.ActiveNode^.DBInfo do
  794.    begin
  795.       TmpStr := GetField(RecNo,FieldNo);
  796.       if DbVars.FullStrings then
  797.          DbGetFldString := TmpStr
  798.       else
  799.          DbGetFldString := Strip('R',' ',TmpStr);
  800.    end;
  801. end; { DbGetFldString }
  802.  
  803. function DbGetFldInt(RecNo: longint; FieldNo: integer): integer;
  804. {}
  805. var TmpStr: string;
  806. begin
  807. {$IFDEF CHECK}
  808.    if DBVARS.ActiveNode = nil then
  809.       DbSetError(103);
  810. {$ENDIF}
  811.    with DbVars.ActiveNode^.DBInfo do
  812.    begin
  813.       DbGetFldInt := 0;
  814.       if DbGetFldType(FieldNo) = DbVars.DbfNFld then
  815.       begin
  816.          TmpStr := GetField(RecNo,FieldNo);
  817.          DbGetFldInt := StrToInt(TmpStr);
  818.       end else
  819.          DbSetError(1027);  { not a numeric field }
  820.    end;
  821. end;  { DbGetFldInt }
  822.  
  823. function DbGetFldLong(RecNo: longint; FieldNo: integer): longint;
  824. {}
  825. var TmpStr: string;
  826. begin
  827. {$IFDEF CHECK}
  828.    if DBVARS.ActiveNode = nil then
  829.       DbSetError(103);
  830. {$ENDIF}
  831.    with DbVars.ActiveNode^.DBInfo do
  832.    begin
  833.       DbGetFldLong := 0;
  834.       if (DbGetFldType(FieldNo) IN [DBVars.DbfNFld,DBVars.DbfMFld]) then
  835.       begin
  836.          TmpStr := GetField(RecNo,FieldNo);
  837.          DbGetFldLong := StrToLong(TmpStr);
  838.       end else
  839.          DbSetError(1027);  { not a numeric field }
  840.    end;
  841. end; { DbGetFldLong }
  842.  
  843. function DbGetFldReal(RecNo: longint; FieldNo: integer): extended;
  844. {}
  845. var TmpStr: string;
  846. begin
  847. {$IFDEF CHECK}
  848.    if DBVARS.ActiveNode = nil then
  849.       DbSetError(103);
  850. {$ENDIF}
  851.    with DbVars.ActiveNode^.DBInfo do
  852.    begin
  853.       DbGetFldReal := 0.0;
  854.       if DbGetFldType(FieldNo) = DbVars.DbfNFld then
  855.       begin
  856.          TmpStr := GetField(RecNo,FieldNo);
  857.          DbGetFldReal := StrToReal(TmpStr);
  858.       end else
  859.          DbSetError(1027);  { not a numeric field }
  860.    end;
  861. end; { DbGetFldReal }
  862.  
  863. function DbGetFldLogical(RecNo: longint; FieldNo: integer): boolean;
  864. {}
  865. var TmpStr: string;
  866. begin
  867. {$IFDEF CHECK}
  868.    if DBVARS.ActiveNode = nil then
  869.       DbSetError(103);
  870. {$ENDIF}
  871.    with DbVars.ActiveNode^.DBInfo do
  872.    begin
  873.       DbGetFldLogical := false;
  874.       if DbGetFldType(FieldNo) = DbVars.DbfLFld then
  875.       begin
  876.          TmpStr := GetField(RecNo,FieldNo);
  877.          DbGetFldLogical := (TmpStr = 'T');
  878.       end else
  879.          DbSetError(1028);  { not a logical field }
  880.    end;
  881. end; { DbGetFldLogical }
  882.  
  883. procedure DbGetFldMemo(RecNo: longint; FieldNo: integer;var MemoDetails:MemoCfg);
  884. {}
  885. const
  886.    SLLNodeLen = 128;
  887. var
  888.    MemoVar: longint;
  889.    MemoBuf: array [0..pred(MemoPageSize)] of char;
  890.    I: byte;
  891.    TempStr: string;
  892.    TempNP: SingleNodePtr;
  893.  
  894.     procedure PassToSL;
  895.     {}
  896.     var
  897.        WorkStr: string[SLLNodeLen];
  898.        Counter: integer;
  899.        P,StrLen: byte;
  900.     begin
  901.        Counter := 0;
  902.        while Counter < I do  {I is number of lines to read}
  903.        begin
  904.           StrLen := GetMin(SLLNodeLen,I - Counter);
  905.           move(MemoBuf[Counter],WorkStr[1],StrLen);
  906.           WorkStr[0] := chr(StrLen);
  907.           {replace CRLF's with end of para codes}
  908.           repeat
  909.              P := pos(CRLF,WorkStr);
  910.              if P > 0 then
  911.              begin
  912.                 delete(Workstr,P,length(CRLF));
  913.                 insert(MemoVars.EndofParaCode,WorkStr,P);
  914.              end;
  915.           until P = 0;
  916.           if _SLLAddStr(SingleLL(MemoDetails.DataSource^),WorkStr) <> 0 then
  917.              DbSetError(1105); { Error reading memo file }
  918.           inc(Counter,StrLen);
  919.        end;
  920.     end; { PassToSL }
  921.  
  922. begin
  923. {$IFDEF CHECK}
  924.    if DBVARS.ActiveNode = nil then
  925.       DbSetError(103);
  926. {$ENDIF}
  927.    with DbVars.ActiveNode^.DBInfo do
  928.    begin
  929.       if MFOpen then
  930.       begin
  931.          if DbGetFldType(FieldNo) <> DbVars.DbfMFld then
  932.             DbSetError(1029) { not a memo field }
  933.          else
  934.          begin
  935.             {$I-} reset(DbtAlias,1); {$I+}
  936.             if IOResult <> 0 then
  937.             begin
  938.                DbSetError(1036); { error reseting dbt file to access memo }
  939.                exit;
  940.             end
  941.             else
  942.             begin
  943.                MemoVar := DbGetFldLong(RecNo,FieldNo);
  944.                if MemoDetails.DataType <> SourceSLL then
  945.                begin
  946.                   DbSetError(1067);
  947.                   exit
  948.                end;
  949.                _SLLDestroy(SingleLL(MemoDetails.DataSource^));   {remove any old entries}
  950.                if (MemoVar <= pMemo^.LastMemoRec) and (MemoVar > 0) then
  951.                begin
  952.                   {$I-} seek(DbtAlias,(MemoVar*MemoPageSize)); {$I+}
  953.                   if IOResult <> 0 then
  954.                   begin
  955.                      DbSetError(1204); { Seek error Reading memo file }
  956.                      exit;
  957.                   end;
  958.                   DbVars.MemoSize := 0;
  959.                   repeat
  960.                      I := 0;
  961.                      blockread(DbtAlias,MemoBuf,MemoPageSize,DbVars.Actual);
  962.                      while (MemoBuf[I] <> char(EOM)) and (I < DbVars.Actual) do
  963.                      begin
  964.                        inc(DbVars.MemoSize);
  965.                        inc(I);
  966.                      end;
  967.                      PassToSL;
  968.                   until (MemoBuf[I] = char(EOM)) or (MemoPageSize <> DbVars.Actual);
  969.                   Memodetails.TotalNodes := SingleLL(MemoDetails.DataSource^).TotalNodes;
  970.                   {check for end of para; if not there, add one}
  971.                   TempStr := _SLLGetStr(SingleLL(MemoDetails.DataSource^),SingleLL(MemoDetails.DataSource^).TotalNodes);
  972.                   if TempStr[length(TempStr)] <> MemoVars.EndofParaCode then
  973.                   begin
  974.                      TempStr := TempStr + MemoVars.EndofParaCode;
  975.                      TempNP := _SLLNodePtr(SingleLL(MemoDetails.DataSource^),SingleLL(MemoDetails.DataSource^).TotalNodes);
  976.                      if _SLLChangeStr(SingleLL(MemoDetails.DataSource^),TempNP,TempStr) <> 0 then {whocares};
  977.                   end;
  978.                   {if wordwrap is on, wrap the field}
  979.                   {$IFDEF WORDWRAP}
  980.                   if MemoDetails.WordWrap then
  981.                      WrapFull(MemoDetails);
  982.                   {$ENDIF}
  983.                end;
  984.             end;
  985.          end;
  986.       end;
  987.    end;
  988. end; { DbGetFldMemo }
  989.  
  990. function DbGetFldDate(RecNo: longint; FieldNo: integer): Dates;
  991. {}
  992. var TmpStr: string;
  993. begin
  994. {$IFDEF CHECK}
  995.    if DBVARS.ActiveNode = nil then
  996.       DbSetError(103);
  997. {$ENDIF}
  998.    with DbVars.ActiveNode^.DBInfo do
  999.    begin
  1000.       DbGetFldDate := 0;
  1001.       if DbGetFldType(FieldNo) = DbVars.DbfDFld then
  1002.       begin
  1003.          TmpStr := GetField(RecNo,FieldNo);
  1004.          DbGetFldDate := StrToJul(TmpStr,YYYYMMDD);
  1005.       end else
  1006.          DbSetError(1031);  { not a date field }
  1007.    end;
  1008. end; { DbGetFldDate }
  1009.  
  1010. procedure DbSetFldString(FieldNo: integer; StrVar: string);
  1011. {}
  1012. var SPos, Len: integer;
  1013. begin
  1014. {$IFDEF CHECK}
  1015.    if DBVARS.ActiveNode = nil then
  1016.       DbSetError(103);
  1017. {$ENDIF}
  1018.    with DbVars.ActiveNode^.DBInfo do
  1019.    begin
  1020.       if DbGetFldType(FieldNo) <> DbVars.DbfCFld then
  1021.          DbSetError(1026)  { field is not a string field }
  1022.       else
  1023.       begin
  1024.          if FieldNo = IndexField then
  1025.          begin
  1026.             BakUpNdxSpc; { copies NdxSpc to BakNdxSpc }
  1027.             Len := NdxFldLen;
  1028.          end else
  1029.             Len := DbGetFldLength(FieldNo);
  1030.          StrVar := PadLeft(StrVar,Len,#32);
  1031.          SPos := StrtPos(FieldNo);
  1032.          move(StrVar[1],WrkSpc^[SPos],Len);
  1033.       end
  1034.    end;
  1035. end; { DbSetFldString }
  1036.  
  1037. procedure DbSetFldInt(FieldNo: integer; IntVar: longint);
  1038. {}
  1039. var SPos, Len: integer;
  1040.     StrIntVar: string;
  1041. begin
  1042. {$IFDEF CHECK}
  1043.    if DBVARS.ActiveNode = nil then
  1044.       DbSetError(103);
  1045. {$ENDIF}
  1046.    with DbVars.ActiveNode^.DBInfo do
  1047.    begin
  1048.       if DbGetFldType(FieldNo) <> DbVars.DbfNFld then
  1049.          DbSetError(1027) { field is not numeric }
  1050.       else
  1051.       begin
  1052.          if FieldNo = IndexField then
  1053.          begin
  1054.             BakUpNdxSpc;
  1055.             Len := NdxFldLen;
  1056.          end else
  1057.             Len := DbGetFldLength(FieldNo);
  1058.          StrIntVar := PadRight(IntToStr(IntVar),Len,#32);
  1059.          SPos := StrtPos(FieldNo);
  1060.          move(StrIntVar[1],WrkSpc^[SPos],Len);
  1061.       end;
  1062.    end;
  1063. end; { DbSetFldInt }
  1064.  
  1065. procedure DbSetFldReal(FieldNo: integer; RealVar: Extended);
  1066. {}
  1067. var SPos, Len: integer;
  1068.     StrRealVar: string;
  1069. begin
  1070. {$IFDEF CHECK}
  1071.    if DBVARS.ActiveNode = nil then
  1072.       DbSetError(103);
  1073. {$ENDIF}
  1074.    with DbVars.ActiveNode^.DBInfo do
  1075.    begin
  1076.       if DbGetFldType(FieldNo) <> DbVars.DbfNFld then
  1077.          DbSetError(1027) { field is not numeric }
  1078.       else
  1079.       begin
  1080.          if FieldNo = IndexField then
  1081.          begin
  1082.             BakUpNdxSpc;
  1083.             Len := NdxFldLen;
  1084.          end else
  1085.             Len := DbGetFldLength(FieldNo);
  1086.          StrRealVar := PadRight(RealToStr(RealVar,DbGetFldDec(FieldNo)),Len,#32);
  1087.          SPos := StrtPos(FieldNo);
  1088.          move(StrRealVar[1],WrkSpc^[SPos],Len);
  1089.       end;
  1090.    end;
  1091. end; { DbSetFldReal }
  1092.  
  1093. procedure DbSetFldLogical(FieldNo: integer; BoolVar: boolean);
  1094. {}
  1095. var SPos: integer;
  1096.     StrBoolVar: char;
  1097. begin
  1098. {$IFDEF CHECK}
  1099.    if DBVARS.ActiveNode = nil then
  1100.       DbSetError(103);
  1101. {$ENDIF}
  1102.    with DbVars.ActiveNode^.DBInfo do
  1103.    begin
  1104.       if DbGetFldType(FieldNo) <> DbVars.DbfLFld then
  1105.          DbSetError(1028) { field is not boolean }
  1106.       else
  1107.       begin
  1108.          if Boolvar then
  1109.             StrBoolVar := 'T'
  1110.          else
  1111.             StrBoolVar := 'F';
  1112.          if FieldNo = IndexField then
  1113.             BakUpNdxSpc;
  1114.          SPos := StrtPos(FieldNo);
  1115.          Move(StrBoolVar,WrkSpc^[SPos],1);
  1116.       end;
  1117.    end;
  1118. end; { DbSetFldLogical }
  1119.  
  1120. procedure DbSetMemoRecNum(FieldNo:integer;MemoRecNo:longint);
  1121. {}
  1122. var SPos: integer;
  1123.     StrMemoVar: string[10];
  1124. begin
  1125. {$IFDEF CHECK}
  1126.    if DBVARS.ActiveNode = nil then
  1127.       DbSetError(103);
  1128. {$ENDIF}
  1129.    with DbVars.ActiveNode^.DBInfo do
  1130.    begin
  1131.       if DbGetFldType(FieldNo) <> DbVars.DbfMFld then
  1132.          DbSetError(1029) { field is not memo }
  1133.       else begin
  1134.          StrMemoVar := PadRight(IntToStr(MemoRecNo),10,' ');
  1135.          SPos := StrtPos(FieldNo);
  1136.          Move(StrMemoVar[1],WrkSpc^[SPos],10);
  1137.       end;
  1138.    end;
  1139. end; { DbSetMemoRecNum }
  1140.  
  1141. function DbSetFldMemoEngine(FldNo: integer; var SL: SingleLL;
  1142.            var FAlias: file; var NextMemoRec,LastMemoRec:longint): longint;
  1143. {Stores memo data in .dbt file and updates memo variable}
  1144. const
  1145.    PadChar: char = 'G';
  1146. var
  1147.    RecNum: longint;
  1148.    Ch: char;
  1149.    I, Counter: integer;
  1150.    MemoBuf: array [0..pred(MemoPageSize)] of char;
  1151.    Str: string;
  1152.    SNP: SingleNodePtr;
  1153.  
  1154.    procedure StrtoBuf;
  1155.    {}
  1156.    var P,S: byte;
  1157.    begin
  1158.       {first, replace endofpara codes with CRLF}
  1159.       repeat
  1160.          P := pos(MemoVars.EndofParaCode,Str);
  1161.          if P <> 0 then
  1162.          begin
  1163.             delete(Str,P,length(MemoVars.EndofParaCode));
  1164.             insert(CRLF,Str,P);
  1165.          end;
  1166.       until P = 0;
  1167.       S := GetMin(length(Str),(MemoPageSize - Counter));
  1168.       move(Str[1],MemoBuf[Counter],S);
  1169.       inc(Counter,S);
  1170.       delete(Str,1,S);
  1171.    end; { StrtoBuf }
  1172.  
  1173. begin
  1174.    DbSetFldMemoEngine := 1;  { failure }
  1175. {$IFDEF CHECK}
  1176.    if DBVARS.ActiveNode = nil then
  1177.       DbSetError(103);
  1178. {$ENDIF}
  1179.    RecNum := NextMemoRec;  {used to update the DBF fld at end of proc}
  1180.    if NextMemoRec > 1 then
  1181.    begin
  1182.       {$I-} seek(FAlias,LastMemoRec * MemoPageSize); {$I+}
  1183.       if IOResult <> 0 then
  1184.       begin
  1185.          DbSetError(1205); { Error seeking while storing memo }
  1186.          exit;
  1187.       end;
  1188.       {scour along last memo in file looking for EOM}
  1189.       Counter := 0;
  1190.       repeat
  1191.          inc(Counter);
  1192.          blockread(FAlias,Ch,1,DbVars.Actual);
  1193.          if DbVars.Actual <> 1 then
  1194.          begin
  1195.             DbSetError(1106); { Error reading memo file while seeking EOM }
  1196.             exit;
  1197.          end;
  1198.       until Ch=char(EOM);
  1199.       for I := 1 to (MemoPageSize - Counter) do  {pad the page to MemoPageSize}
  1200.       begin
  1201.          blockwrite(FAlias,PadChar,1,DbVars.Actual);
  1202.          if DbVars.Actual <> 1 then
  1203.          begin
  1204.             DbSetError(1037);
  1205.             exit;
  1206.          end;
  1207.       end;
  1208.    end
  1209.    else
  1210.    begin
  1211.       {$I-} seek(FAlias, MemoPageSize); {$I+}
  1212.       if IOResult <> 0 then
  1213.       begin
  1214.          DbSetError(1205); { Error seeking while storing memo }
  1215.          exit;
  1216.       end;
  1217.    end;
  1218.    {now we are positioned at the end of the file with all
  1219.     previous memos (if any) occupying MemoPageSize bytes}
  1220.    Str := '';
  1221.    Counter := 0;
  1222.    SNP := _SLLNodePtr(SL,1);
  1223.    while (Str <> '') or (SNP <> nil) do
  1224.    begin
  1225.       if Str = '' then
  1226.       begin
  1227.          Str := _SLLGetNodeStr(SL,SNP,0);
  1228.          SNP := SNP^.NextPtr;
  1229.       end;
  1230.       StrToBuf;
  1231.       if Counter = MemoPageSize then
  1232.       begin
  1233.          blockwrite(FAlias,MemoBuf,MemoPageSize,DbVars.Actual);
  1234.          if DbVars.Actual <> MemoPageSize then
  1235.          begin
  1236.             DbSetError(1037);
  1237.             exit;
  1238.          end;
  1239.          inc(NextMemoRec);
  1240.          Counter := 0;
  1241.       end;
  1242.    end;
  1243.    if Counter <> 0 then {need to flush the buffer to disk}
  1244.    begin
  1245.       blockwrite(FAlias,MemoBuf,Counter,DbVars.Actual);
  1246.       if DbVars.Actual <> Counter then
  1247.       begin
  1248.          DbSetError(1037);
  1249.          exit;
  1250.       end;
  1251.       inc(NextMemoRec);
  1252.    end;
  1253.    if Counter = 511 then  {the two extra bytes will spill into the next page}
  1254.       inc(NextMemoRec);
  1255.    {time to write the end-of-memo characters twice}
  1256.    for I := 1 to 2 do
  1257.    begin
  1258.       blockwrite(FAlias,EOM,1,DbVars.Actual);
  1259.       if DbVars.Actual <> 1 then
  1260.        begin
  1261.          DbSetError(1037);
  1262.          exit;
  1263.       end;
  1264.    end;
  1265.    {$I-} seek(FAlias,0); {$I+}
  1266.    if IOResult <> 0 then
  1267.    begin
  1268.       DbSetError(110);
  1269.       exit;
  1270.    end;
  1271.    blockwrite(FAlias,NextMemoRec,sizeof(NextMemoRec),DbVars.Actual);
  1272.    if DbVars.Actual <> sizeof(NextMemoRec) then
  1273.       DbSetError(1037)
  1274.    else
  1275.    begin
  1276.       DbSetMemoRecNum(FldNo,RecNum);
  1277.       DbSetFldMemoEngine := 0;
  1278.    end;
  1279.    LastMemoRec := pred(NextMemoRec);
  1280. end; { DbSetFldMemoEngine }
  1281.  
  1282.  
  1283. function DbSetFldMemo(FldNo: integer; var SL: SingleLL): longint;
  1284. begin
  1285.    with DbVars.ActiveNode^,DBInfo,pMemo^ do
  1286.    begin
  1287.      if MFOpen then
  1288.         DbSetFldMemo := DbSetFldMemoEngine(FldNo,SL,DBTAlias,NextMemoRec,LastMemoRec)
  1289.      else
  1290.         DbSetFldMemo := 1;
  1291.    end
  1292. end; { DbSetFldMemo }
  1293.  
  1294. procedure DbSetFldDate(FieldNo: integer; DateVar: longint);
  1295. {}
  1296. var SPos: integer;
  1297.     StrDateVar: string;
  1298. begin
  1299. {$IFDEF CHECK}
  1300.    if DBVARS.ActiveNode = nil then
  1301.       DbSetError(103);
  1302. {$ENDIF}
  1303.    with DbVars.ActiveNode^.DBInfo do
  1304.    begin
  1305.       if DbGetFldType(FieldNo) <> DbVars.DbfDFld then
  1306.          DbSetError(1031) { field is not a date field }
  1307.       else
  1308.       begin
  1309.          if FieldNo = IndexField then
  1310.             BakUpNdxSpc;
  1311.          StrDateVar := StripDateStr(JulToStr(DateVar,YYYYMMDD),YYYYMMDD);
  1312.          SPos := StrtPos(FieldNo);
  1313.          Move(StrDateVar[1],WrkSpc^[SPos],8);
  1314.       end;
  1315.    end;
  1316. end; { DbSetFldDate }
  1317.  
  1318. function DbFldIsEmpty(RecNo: longint;FieldNo: integer): boolean;
  1319. {}
  1320. begin
  1321. {$IFDEF CHECK}
  1322.    if DBVARS.ActiveNode = nil then
  1323.       DbSetError(103);
  1324. {$ENDIF}
  1325.    with DbVars.ActiveNode^.DBInfo do
  1326.       DbFldIsEmpty := (Strip('A',' ',GetField(RecNo,FieldNo)) = '');
  1327. end; { DbFldIsEmpty }
  1328.  
  1329. procedure DbClearWrkSpc;
  1330. {}
  1331. begin
  1332. {$IFDEF CHECK}
  1333.    if DBVARS.ActiveNode = nil then
  1334.       DbSetError(103);
  1335. {$ENDIF}
  1336.    with DbVars.ActiveNode^.DBInfo do
  1337.       fillchar(WrkSpc^,DbGetRecLen,#32);
  1338. end; { DbClearWrkSpc }
  1339.  
  1340. procedure DbPutHeader( var Alias: file );
  1341. {}
  1342. begin
  1343. {$IFDEF CHECK}
  1344.    if DBVARS.ActiveNode = nil then
  1345.       DbSetError(103);
  1346. {$ENDIF}
  1347.    with DbVars.ActiveNode^.DBInfo do
  1348.    begin
  1349.       DbPutUpDate; { update current date }
  1350.       {$I-} seek(Alias,0); {$I+}
  1351.       if IOResult <> 0 then
  1352.          DbSetError(1206) { Seek error while updating header }
  1353.       else
  1354.       begin
  1355.          blockwrite(Alias,pHead^,sizeof(pHead^),DbVars.Actual);
  1356.          if DbVars.Actual <> sizeof(pHead^) then
  1357.             DbSetError(1161); { Write error while updating header info }
  1358.          vHdrModified := false;
  1359.       end;
  1360.    end;
  1361. end; { DBPutHeader }
  1362.  
  1363. procedure DbAddRecord;
  1364. {}
  1365. begin
  1366. {$IFDEF CHECK}
  1367.    if DBVARS.ActiveNode = nil then
  1368.       DbSetError(103);
  1369. {$ENDIF}
  1370.    with DbVars.ActiveNode^.DBInfo do
  1371.    begin
  1372.       WrkSpc^[1] := #32;  { set to active }
  1373.       FPos := DbGetHdrLen + ( DbGetNumRecs * DbGetRecLen );
  1374.       {$I-} seek(DBFAlias,FPos); {$I+} { Set file pointer to end of file }
  1375.       if IOResult <> 0 then
  1376.          DbSetError(1207) { Unable to seek to EOF to add record }
  1377.       else
  1378.       begin
  1379.          blockwrite(DBFAlias,WrkSpc^[1],DbGetRecLen,DbVars.Actual);
  1380.          if DbVars.Actual <> DbGetRecLen then
  1381.             DbSetError(1162) { Unable to write new record, blockwrite failed }
  1382.          else
  1383.          begin
  1384.             blockwrite(DBFAlias,EOFile,sizeof(EOFile),DbVars.Actual);   { Write EOF }
  1385.             if DbVars.Actual <> sizeof(EOFile) then
  1386.                DbSetError(1163) { Unable to write EOF while adding new record }
  1387.             else
  1388.             begin
  1389.                DbPutNumRecs(succ(DbGetNumRecs));
  1390.                DbPutHeader(DBFAlias);
  1391.                CurrentRec := DbGetNumRecs;
  1392.                if IndexField <> 0 then
  1393.                begin
  1394.                   NdxAddKey;
  1395.                   move(WrkSpc^[StrtPos(IndexField)],NdxSpc^,NdxFldLen);
  1396.                end;
  1397.             end;
  1398.          end;
  1399.       end;
  1400.    end;
  1401. end; { DbAddRecord }
  1402.  
  1403. procedure DbDeleteRecord( RecNo: longint );
  1404. {}
  1405. begin
  1406. {$IFDEF CHECK}
  1407.    if DBVARS.ActiveNode = nil then
  1408.       DbSetError(103);
  1409. {$ENDIF}
  1410.    with DbVars.ActiveNode^.DBInfo do
  1411.    begin
  1412.       if RecNo <> DbCurrRecNum then
  1413.          DbGetRecord(RecNo);
  1414.       if (WrkSpc^[1] = chr(Space)) then
  1415.       begin
  1416.          WrkSpc^[1] := chr(Astk);
  1417.          DbPutRecord;
  1418.          if IndexField <> 0 then
  1419.             NdxDelKey(RecNo);
  1420.       end;
  1421.    end;
  1422. end; { DbDeleteRecord }
  1423.  
  1424. procedure DbUnDeleteRecord( RecNo: longint );
  1425. {}
  1426. var OK: boolean;
  1427. begin
  1428. {$IFDEF CHECK}
  1429.    if DBVARS.ActiveNode = nil then
  1430.       DbSetError(103);
  1431. {$ENDIF}
  1432.    with DbVars.ActiveNode^.DBInfo do
  1433.    begin
  1434.       if RecNo <> DbCurrRecNum then
  1435.          DbGetRecord(RecNo);
  1436.       if (WrkSpc^[1] = chr(Astk)) then
  1437.       begin
  1438.          WrkSpc^[1] := chr(Space);
  1439.          DbPutRecord;
  1440.          if IndexField <> 0 then
  1441.             NdxAddKey;
  1442.       end;
  1443.    end;
  1444. end; { UnDeleteRecord }
  1445.  
  1446. procedure DbGetRecord( RecNo: longint );
  1447. {}
  1448. var TmpNdx: string[MaxNdxLen];
  1449. begin
  1450. {$IFDEF CHECK}
  1451.    if DBVARS.ActiveNode = nil then
  1452.       DbSetError(103);
  1453. {$ENDIF}
  1454.    with DbVars.ActiveNode^.DBInfo do
  1455.    begin
  1456.       if ( RecNo < 1 ) OR ( RecNo > 1048576 ) then
  1457.          DBSetError(1032) { Out-of-range }
  1458.       else
  1459.       begin
  1460.          FPos := DbGetHdrLen + ( pred(RecNo) * DbGetRecLen );
  1461.          {$I-} seek(DBFAlias,FPos); {$I+}
  1462.          if IOResult <> 0 then
  1463.             DbSetError(1213) { Seek error within DbGetRecord }
  1464.          else
  1465.          begin
  1466.             blockread(DBFAlias, WrkSpc^[1], DbGetRecLen, DbVars.Actual);
  1467.             if DbVars.Actual <> DbGetRecLen then
  1468.                DbSetError(1067) { Read error within DbGetRecord }
  1469.             else
  1470.             begin
  1471.                CurrentRec := RecNo;
  1472.                if SaveIndexFldValue and (IndexField <> 0) then
  1473.                begin
  1474.                   if NdxSpc = nil then
  1475.                      AllocateNdxSpc;
  1476.                   move(WrkSpc^[StrtPos(IndexField)],NdxSpc^,NdxFldLen);
  1477.                end;
  1478.             end;
  1479.          end;
  1480.       end;
  1481.    end;
  1482. end; { DbGetRecord }
  1483.  
  1484. procedure DbPutRecord;
  1485. {}
  1486.    procedure WriteRec;
  1487.    begin
  1488.    {$IFDEF CHECK}
  1489.       if DBVARS.ActiveNode = nil then
  1490.          DbSetError(103);
  1491.    {$ENDIF}
  1492.       with DbVars.ActiveNode^.DBInfo do
  1493.       begin
  1494.          FPos := DbGetHdrLen + ( pred(CurrentRec) * DbGetRecLen );
  1495.          {$I-} seek(DBFAlias,FPos); {$I+}
  1496.          if IOResult <> 0 then
  1497.             DbSetError(1214) { Seek error putting record }
  1498.          else
  1499.          begin
  1500.             blockwrite(DBFAlias,WrkSpc^[1],DbGetRecLen,DbVars.Actual);
  1501.             if DbVars.Actual <> DbGetRecLen then
  1502.                DbSetError(1166) { Write error putting record }
  1503.             else
  1504.                DbPutHeader(DBFAlias);       {to update date modified}
  1505.          end;
  1506.       end;
  1507.    end;
  1508.  
  1509. begin
  1510. {$IFDEF CHECK}
  1511.    if DBVARS.ActiveNode = nil then
  1512.       DbSetError(103);
  1513. {$ENDIF}
  1514.    with DbVars.ActiveNode^.DBInfo do
  1515.    begin
  1516.       if (IndexField <> 0)
  1517.       and dbRecordIsActive(CurrentRec)
  1518.       and dbIndexFieldChanged then  {update the index}
  1519.       begin
  1520.          DeletingIndexEntry := true;
  1521.          NdxDelKey(CurrentRec);
  1522.          DeletingIndexEntry := false;
  1523.          WriteRec;
  1524.          NdxAddKey;
  1525.          move(WrkSpc^[StrtPos(IndexField)],NdxSpc^,NdxFldLen);
  1526.       end else
  1527.          WriteRec;
  1528.    end;
  1529. end; { PutRecord }
  1530.  
  1531. function DbSeqSearch( var RecNo: longint;
  1532.                           FieldNo: integer;
  1533.                           SearchTxt: String ): boolean;
  1534. {}
  1535. var L: longint;
  1536.     TmpStr, TmpStr1: string;
  1537.     I: integer;
  1538. begin
  1539.    DbSeqSearch := false;
  1540. {$IFDEF CHECK}
  1541.    if DBVARS.ActiveNode = nil then
  1542.       DbSetError(103);
  1543. {$ENDIF}
  1544.    with DbVars.ActiveNode^.DBInfo do
  1545.    begin
  1546.       if DbGetNumRecs > 0 then
  1547.       begin
  1548.          SearchTxt := SetUpper(SearchTxt);
  1549.          if RecNo = 0 then
  1550.             RecNo := 1;
  1551.          for L := RecNo to DbGetNumRecs do
  1552.          begin
  1553.             TmpStr := SetUpper(DbGetFldString(L,FieldNo));
  1554.             if SearchTxt[0] <= TmpStr[0] then
  1555.             begin
  1556.                if ( pos(SearchTxt,TmpStr) <> 0 ) then
  1557.                begin
  1558.                   DbSeqSearch := true;
  1559.                   RecNo := L;
  1560.                   exit;
  1561.                end;
  1562.             end;
  1563.          end;
  1564.       end;
  1565.    end;
  1566. end; { DbSeqSearch }
  1567.  
  1568. function DbPackFile(FName: PathStr; IndexField: integer): integer;
  1569. {DBF must be closed}
  1570. var TF: file;
  1571.     BufPtr: pointer;
  1572.     Stat: byte;
  1573.     PackHandle: integer;
  1574.     HdrLen,
  1575.     RecLen,
  1576.     Counter: longint;
  1577.     FilesClosed,
  1578.     CloseBoth: boolean;
  1579.     IFile: PathStr;
  1580.     DFile: PathStr;
  1581.  
  1582.     procedure CloseFiles;
  1583.     begin
  1584.        with DbVars.ActiveNode^.DBInfo do
  1585.        begin
  1586.           if not FilesClosed then
  1587.           begin
  1588.              {$I-} close(TF); {$I+}
  1589.              if (IOResult = 0) then
  1590.              begin
  1591.                 if CloseBoth then
  1592.                    DbCloseDataBase(PackHandle);
  1593.              end
  1594.              else
  1595.                 DbSetError(900); { close failure }
  1596.              FilesClosed := true;
  1597.           end;
  1598.        end;
  1599.     end; { CloseFiles }
  1600.  
  1601.     function MoveHeader: integer;
  1602.     {}
  1603.     var L: integer;
  1604.     begin
  1605.        MoveHeader := 1;
  1606.        with DbVars.ActiveNode^.DBInfo do
  1607.        begin
  1608.           HdrLen := DbGetHdrLen;
  1609.           if GoldMaxAvail < HdrLen then
  1610.              DBSetError(1009) { Insufficient heap available to move header }
  1611.           else
  1612.           begin
  1613.              getmem(BufPtr,HdrLen);
  1614.              seek(DBFAlias,0);
  1615.              blockread(DBFAlias,BufPtr^,HdrLen,DbVars.Actual);
  1616.              if DbVars.Actual <> HdrLen then
  1617.                 DbSetError(1109) { Unable to read dbf file while packing }
  1618.              else
  1619.              begin
  1620.                 blockwrite(TF,BufPtr^,HdrLen,DbVars.Actual);
  1621.                 if DbVars.Actual <> HdrLen then
  1622.                    DbSetError(1156) { Unable to write to temp file while packing }
  1623.                 else
  1624.                    MoveHeader := 0;
  1625.              end;
  1626.              freemem(BufPtr,HdrLen);
  1627.           end;
  1628.           {error}
  1629.        end;
  1630.     end; { MoveHeader }
  1631.  
  1632.     function MoveRecords: integer;
  1633.     {}
  1634.     var L: integer;
  1635.     begin
  1636.        MoveRecords := 1;
  1637.        with DbVars.ActiveNode^.DBInfo do
  1638.        begin
  1639.           Counter := 0;
  1640.           for L := 1 to DbGetNumRecs do
  1641.           begin
  1642.              if DbRecordIsActive(L) then
  1643.              begin
  1644.                 blockwrite(TF,WrkSpc^[1],RecLen,DbVars.Actual);
  1645.                 if DbVars.Actual <> RecLen then
  1646.                    DbSetError(1158) { Unable to write record while packing }
  1647.                 else
  1648.                    inc(Counter);
  1649.              end;
  1650.           end;
  1651.           blockwrite(TF,EOFile,1,DbVars.Actual);
  1652.           if DbVars.Actual <> 1 then
  1653.              DbSetError(1159) { Unable to write EOF to Temp file while packing }
  1654.           else
  1655.           begin
  1656.              DbPutNumRecs(Counter);
  1657.              DbPutHeader(TF);
  1658.              MoveRecords := 0;
  1659.           end;
  1660.        end;
  1661.     end; { MoveRecords }
  1662.  
  1663. begin
  1664.    DbPackFile := 1;
  1665.    assign( TF, dbTempFname );
  1666.    {$I-} rewrite( TF, 1 ); {$I+} { open temp file }
  1667.    if IOResult <> 0 then
  1668.      DbSetError(1301) { Error rewriting file in PackFile }
  1669.    else
  1670.    begin
  1671.       IFile := SlashedDirectory(FileDirectory(FName))+FileName(FName)+IFX;
  1672.       DFile := SlashedDirectory(FileDirectory(FName))+FileName(FName)+DFX;
  1673.       if Exist(IFile) then
  1674.          if DeleteFile(IFile) <> 0 then
  1675.             DBSetError(1087); {Unable to delete index file}
  1676.       PackHandle := DBOpenDataSet(DFile);
  1677.       if PackHandle > 0 then
  1678.       begin
  1679.          CloseBoth := true;
  1680.          if DbGetNumRecs < 1 then
  1681.             DbSetError(1008) { No records Available }
  1682.          else
  1683.          begin
  1684.             DbVars.Packing := true;
  1685.             FilesClosed := false;
  1686.             RecLen := DbGetRecLen;
  1687.             if (MoveHeader = 0) and (MoveRecords = 0) then
  1688.             begin
  1689.                CloseFiles;
  1690.                if (DeleteFile(DFile) = 0) then
  1691.                   if (RenameFile(dbTempFname,DFile) = 0) then
  1692.                   begin
  1693.                      PackHandle := DbOpenDataSet(DFile);
  1694.                      if PackHandle > 0 then
  1695.                      begin
  1696.                         DbPackFile := 0;
  1697.                         if (IndexField > 0) then
  1698.                            if NdxBuildNew(IndexField) <> 0 then
  1699.                               DbSetError(1085); { potential corruption }
  1700.                         DbCloseDataBase(PackHandle);
  1701.                      end;
  1702.                   end;
  1703.             end;
  1704.          end;
  1705.       end;
  1706.    end;
  1707.    DbVars.Packing := false;
  1708. end; { DbPackFile }
  1709.  
  1710.                   {*************************************}
  1711.                   {**  BEGIN .dbf file build methods  **}
  1712.                   {*************************************}
  1713.  
  1714. function DbValidName( var Name: string ): boolean;
  1715. {}
  1716. var I, N, Len: integer;
  1717. begin
  1718.    DbValidName := false;
  1719.    if Name <> '' then
  1720.    begin
  1721.       Name := SetUpper(Name); { MUST be uppercase }
  1722.       Len := length(Name);
  1723.       if ( Len > 10 ) then
  1724.       begin
  1725.          Name[0] := chr(10);
  1726.          Len := 10;
  1727.       end;
  1728.       if ( Name[1] in ['A'..'Z','_'] ) then
  1729.       begin
  1730.          N := 0;
  1731.          for I := 2 to Len do
  1732.              inc(N,ord( not (Name[I] in ['A'..'Z','0'..'9','_'] )));
  1733.          if N = 0 then
  1734.          begin
  1735.             Name := PadLeft(Name,11,#0);
  1736.             DbValidName := true;
  1737.          end;
  1738.       end;
  1739.    end;
  1740. end; { DbValidName }
  1741.  
  1742. function DbValidType( var FldType: char ): boolean;
  1743. {}
  1744. begin
  1745.    DbValidType := false;
  1746.    FldType := UpCase(FldType);
  1747.    with DbVars do
  1748.    begin
  1749.       if ( FldType IN [DbfCFld, DbfNFld, DbfLFld, DbfDFld, DbfMFld] ) then
  1750.       begin
  1751.          DbValidType := true;
  1752.          with DbVars.ActiveNode^.DBInfo do
  1753.          begin
  1754.             if (not MemoIsIncluded) and (FldType = DbfMFld) then
  1755.             begin
  1756.                MemoIsIncluded := true;
  1757.                HasMemo := true;
  1758.             end;
  1759.          end;
  1760.       end;
  1761.    end;
  1762. end; { DbValidType }
  1763.  
  1764. function DbValidFldLen( var FldLen: integer; FldType: char ): boolean;
  1765. {}
  1766. begin
  1767.    with DbVars do
  1768.    begin
  1769.       if (( FldType = DbfCFld ) and ( FldLen in [1..254] ))
  1770.       or (( FldType = DbfNFld ) and ( FldLen in [1..19] )) then
  1771.          DbValidFldLen := true
  1772.       else
  1773.       if ( FldType = DbfLFld ) then { true or false - 0 or 1 }
  1774.       begin
  1775.          FldLen := 1;
  1776.          DbValidFldLen := true;
  1777.       end else
  1778.       if ( FldType = DbfDFld ) then { date field = 8  YYYYMMDD }
  1779.       begin
  1780.          FldLen := 8;
  1781.          DbValidFldLen := true;
  1782.       end else
  1783.       if ( FldType = DbfMFld ) then { memo = 10, index for dbt file }
  1784.       begin
  1785.          FldLen := 10;
  1786.          DbValidFldLen := true;
  1787.       end else
  1788.       DbValidFldLen := false;
  1789.    end;
  1790. end; { DbValidFldLen }
  1791.  
  1792. procedure DbValidateFldDecPl( var FldDecPl, FldLen:integer; FldType:char );
  1793. {}
  1794. begin
  1795.    with DBVars do
  1796.    begin
  1797.       if ( FldType <> DbfNFld )
  1798.       or ( FldDecPl < 0 )
  1799.       or ( FldDecPl > 15 )
  1800.       or ( FldLen < 3 ) then
  1801.          FldDecPl := 0;
  1802.       if ( FldDecPl > FldLen - 2) and (FldDecPL > 1) then
  1803.          FldDecPl := FldLen - 2;
  1804.    end;
  1805. end; { DbValidateFldDecPl }
  1806.  
  1807. function DbAddDbfField( FldName: string; FldType: char; FldLen, FldDecPl: integer ): integer;
  1808. {}
  1809. var FldArray: Array [1..32] of char;
  1810.     AddResult: integer;
  1811.  
  1812. begin
  1813.    if not DbVars.FldLstIsActive then
  1814.       with DbVars do
  1815.       begin
  1816.          InitSLL(DbfFieldList);
  1817.          FldLstIsActive := true;
  1818.       end;
  1819.    if DbVars.FldLstIsActive then
  1820.    begin
  1821.       with DbVars do
  1822.       begin
  1823.          DbAddDbfField := 0; { Success }
  1824.          fillchar(FldArray,sizeof(FldArray),#0);
  1825.          if ( DbfFieldList.TotalNodes > 127 ) then
  1826.             DbSetError(1000)  { too many fields }
  1827.          else
  1828.          if not DbValidName( FldName ) then       { Field name validation }
  1829.             DbSetError(1005)
  1830.          else
  1831.          if not DbValidType( FldType ) then       { Field type validation }
  1832.             DbSetError(1006)
  1833.          else
  1834.          if not DbValidFldLen( FldLen, FldType ) then      { Field length validation }
  1835.             DbSetError(1007)
  1836.          else
  1837.          begin
  1838.             DbValidateFldDecPl( FldDecPl, FldLen, FldType );  { Field decimal place validation }
  1839.             move(FldName[1],FldArray[1],11);
  1840.             move(FldType,FldArray[12],1);
  1841.             move(FldLen,FldArray[17],1);
  1842.             move(FldDecPl,FldArray[18],1);
  1843.             AddResult := _SLLAdd(DbfFieldList,FldArray,sizeof(FldArray));
  1844.             if ( AddResult = 2 ) then
  1845.             with DbfFieldList do
  1846.             begin
  1847.                _SLLDelNode(DbfFieldList,_SLLNodePtr(DbfFieldList,TotalNodes));
  1848.                DbSetError(1024); { not enough memory }
  1849.                DbAddDbfField := 7; { insufficient memory }
  1850.             end;
  1851.          end;
  1852.       end;
  1853.    end else
  1854.       DbAddDbfField := 6;
  1855. end; { DbAddDbfField }
  1856.  
  1857. function DbBuildDataFile( FN: Pathstr; NdxFld : byte): integer;
  1858. { Creates dbf file }
  1859. var TmpHandle: integer;
  1860.     DF: file;
  1861.     FldArray: array [1..32] of char;
  1862.     TmpHead: HeaderInfo;
  1863.     TmpField: FieldDesc;
  1864.     vYear,vMth,vDay,vDow: word;
  1865.     FLength: Byte;
  1866.     FdType:Char;
  1867.  
  1868.    function CreateFields: boolean;
  1869.    {}
  1870.    var I: integer;
  1871.    begin
  1872.       with DBVars do
  1873.       begin
  1874.          CreateFields := false;
  1875.          fillchar(TmpHead.Reserved,sizeof(TmpHead.Reserved),0);    { Clean reserved fields }
  1876.          fillchar(FldArray,sizeof(FldArray),0);
  1877.          TmpHead.RecLen := 0;
  1878.          with DbfFieldList do
  1879.          begin
  1880.             if ( TotalNodes = 0 ) or ( not FldLstIsActive ) then
  1881.                DbSetError(1086) { nothing to write }
  1882.             else
  1883.             begin
  1884.                for I := 1 to TotalNodes do
  1885.                begin
  1886.                   SLLGetNodeData(_SLLNodePtr(DbfFieldList,I),FldArray);
  1887.                   blockwrite(DF,FldArray[1],sizeof(FldArray),DbVars.Actual);
  1888.                   if (DbVars.Actual <> sizeof(FldArray)) then
  1889.                   begin
  1890.                      DbSetError(1151); { Write error creating header }
  1891.                      exit;
  1892.                   end;
  1893.                   inc(TmpHead.RecLen,integer(FldArray[17]));
  1894.                   if I = NdxFld then
  1895.                   begin
  1896.                      FLength := integer(FldArray[17]);
  1897.                      FDType := FldArray[12];
  1898.                   end;
  1899.                end;
  1900.                blockwrite(DF,EOH,1,DbVars.Actual);   {End of hdr}
  1901.                if (DbVars.Actual <> 1) then
  1902.                   DbSetError(1152) { Unable to write EOH creating DBF file }
  1903.                else
  1904.                begin
  1905.                   blockwrite(DF,EOFile,1,DbVars.Actual); {EndOfFile}
  1906.                   if (DbVars.Actual <> 1) then
  1907.                      DbSetError(1153) { Unable to write EOF creating DBF file }
  1908.                   else
  1909.                      CreateFields := true;
  1910.                end;
  1911.             end;
  1912.          end;
  1913.       end;
  1914.    end; { CreateFields }
  1915.  
  1916. begin
  1917.    if DBVars.FldLstIsActive then
  1918.    with DbVars do
  1919.    begin
  1920.       DbBuildDataFile := 1;  { set to error condition }
  1921.       HasMemo := false;
  1922.       { validate file name then add dbf extension }
  1923.       FN := FileName(FN) + DFX;
  1924.       assign(DF,FN);
  1925.       {$I-} rewrite(DF,1); {$I+} {Set record size to 1}
  1926.       if IOResult <> 0 then
  1927.          DbSetError(1039) { Unable to create DBF file }
  1928.       else
  1929.       begin
  1930.          {$I-} seek(DF,32); {$I+} {Beginning of fields}
  1931.          if IOResult <> 0 then
  1932.             DbSetError(1201) { seek error creating DBF file }
  1933.          else
  1934.          if CreateFields then
  1935.          begin
  1936.             with DbVars do
  1937.             begin
  1938.                if HasMemo then
  1939.                   TmpHead.VersionNumber := $83
  1940.                else
  1941.                   TmpHead.VersionNumber := $03;
  1942.                getdate(vYear,vMth,vDay,vDow);
  1943.                TmpHead.Update[1] := vYear-1900;
  1944.                TmpHead.Update[2] := vMth;
  1945.                TmpHead.Update[3] := vDay;
  1946.                TmpHead.NbrRec := 0;
  1947.                TmpHead.HdrLen := ( DbfFieldList.TotalNodes * 32 ) + 33;
  1948.                TmpHead.RecLen := TmpHead.RecLen + 1; { single status byte }
  1949.             end;
  1950.             {$I-} seek(DF,0); {$I+} {Set to beginning of FILE}
  1951.             if IOResult <> 0 then
  1952.                DbSetError(1201) { seek error creating DBF file }
  1953.             else
  1954.             begin
  1955.                blockwrite(DF,TmpHead,sizeof(TmpHead),DbVars.Actual);
  1956.                if DbVars.Actual <> sizeof(TmpHead) then
  1957.                   DbSetError(1154) { Error writing header while creating DBF file }
  1958.                else
  1959.                begin
  1960.                   DbBuildDataFile := 0;
  1961.                   {$I-} close(DF); {$I+}
  1962.                   If IOResult <> 0 then
  1963.                      DbSetError(901); { close failure }
  1964.                end;
  1965.                if (NDXFld > 0) and (NDXFld < succ(DbfFieldList.TotalNodes)) then
  1966.                begin
  1967.                   TmpHandle := DbOpenDataSet(FN);
  1968.                   if TmpHandle > 0 then
  1969.                   begin
  1970.                      if NdxBuildNew(NDXFld) = 0 then ;
  1971.                         if DbVars.HasMemo then
  1972.                            DbBuildMemoFile(FileName(FN)+MFX);
  1973.                      DbCloseDataBase(TmpHandle);
  1974.                   end;
  1975.                end;
  1976.             end;
  1977.             FldLstIsActive := false;
  1978.             DbVars.HasMemo := false; { reset }
  1979.             _SLLDestroy(DbfFieldList);
  1980.             DbVars.FldLstIsActive := false;
  1981.          end;
  1982.       end;
  1983.    end;
  1984. end; { DbBuildDataFile }
  1985.  
  1986.                    {***********************************}
  1987.                    {**  END .dbf file build methods  **}
  1988.                    {***********************************}
  1989.  
  1990. procedure DbBuildMemoFile(FName:PathStr);
  1991. {}
  1992. var MemoHdrBlk: MemoDesc;
  1993.     MemoFile: file;
  1994. begin
  1995.    with MemoHdrBlk do
  1996.    begin
  1997.       NextMemoRec := 1;
  1998.       fillchar(EmptySpace,sizeof(EmptySpace),#0);
  1999.       assign(MemoFile,FName);
  2000.       {$I-} rewrite(MemoFile,1); {$I+}
  2001.       if IOResult <> 0 then
  2002.          DbSetError(1033)  { Error building new memo file }
  2003.       else
  2004.       begin
  2005.          blockwrite(MemoFile,MemoHdrBlk,sizeof(MemoHdrBlk),DbVars.Actual);
  2006.          if DbVars.Actual <> sizeof(MemoHdrBlk) then
  2007.             DbSetError(1155); { Write error during memo file creation }
  2008.          {$I-} close(MemoFile); {$I+}
  2009.          if IOResult <> 0 then
  2010.             DbSetError(902); {close failure}
  2011.       end;
  2012.    end;
  2013. end; { DBBuildMemoFile }
  2014.  
  2015. function DbRebuildMemo(FName: PathStr): integer;
  2016. {}
  2017. var I,J: longint;
  2018.     Handle: integer;
  2019.     MemoD: MemoCfg;
  2020.     MemoL: SingleLL;
  2021.     MemoRec: longint;
  2022.     TempMemoFile: File;
  2023.     NxtMemoRec,LstMemoRec: longint;
  2024. begin
  2025.    DbRebuildMemo := 1;
  2026.    Handle := DbOpenDataSet(FName);
  2027.    if Handle = 0 then
  2028.       DbSetError(1019) {Cannot activate database; closed or inactive handle}
  2029.    else
  2030.    begin
  2031.       with DbVars.ActiveNode^.DBInfo do
  2032.       begin
  2033.          if MemoIsIncluded then
  2034.          begin
  2035.             DbBuildMemoFile(DbTempFName);
  2036.             {now open the file}
  2037.             assign(TempMemoFile,FName);
  2038.             {$I-} reset(TempMemoFile,1); {$I+}
  2039.             if IoResult <> 0 then
  2040.             begin
  2041.                DbSetError(1301); { Error in temp memo file }
  2042.                exit;
  2043.             end;
  2044.             NxtMemoRec := 1;
  2045.             LstMemoRec := 0;
  2046.             InitSLL(MemoL);
  2047.             MemoAssignSLL(MemoD,MemoL);
  2048.             for I := 1 to DbGetNumRecs do
  2049.                if DbRecordIsActive(I) then
  2050.                   for J := 1 to DbTotalFields do
  2051.                   begin
  2052.                      if DbGetFldType(J) = DbVars.DbfMFld then
  2053.                      begin
  2054.                         DbGetFldMemo(I,J,MemoD);
  2055.                         if DbSetFldMemoEngine(J,MemoL,DBTAlias,NxtMemoRec,LstMemoRec) <> 0 then
  2056.                            DbSetError(1088);  {Error rebuilding memo file}
  2057.                      end;
  2058.                   end;
  2059.                { close memo files and rename }
  2060.                {!!!!}
  2061.            DbReBuildMemo := 0;
  2062.          end
  2063.          else
  2064.            DbSetError(1023);
  2065.       end;
  2066.    end;
  2067. end; { RebuildMemo }
  2068.  
  2069.                         {*************************}
  2070.                         {**  End of Memo Stuff  **}
  2071.                         {*************************}
  2072.  
  2073. procedure SetToPrevNode( Node: DBListNodePtr );
  2074. {}
  2075. var TempNode1, TempNode2: DBListNodePtr;
  2076. begin
  2077.    if Node <> nil then
  2078.    with DbVars do
  2079.    begin
  2080.       TempNode1 := StartNode;
  2081.       if Node <> StartNode then
  2082.       begin
  2083.          while TempNode1^.NextPtr <> Node do
  2084.          begin
  2085.             TempNode2 := TempNode1^.NextPtr;
  2086.             TempNode1 := TempNode2;
  2087.          end;
  2088.       end;
  2089.       DbVars.ActiveNode := TempNode1;
  2090.    end;
  2091. end; { SetToPrevNode }
  2092.  
  2093. procedure DbCloseDataBase( Handle: integer );
  2094. {}
  2095. begin
  2096.    if (Handle > 0) and (Handle < succ(DbVars.DBsOpen)) then
  2097.    begin
  2098.       DbSetActiveDatabase(Handle);
  2099. {$IFDEF CHECK}
  2100.    if DBVARS.ActiveNode = nil then
  2101.       DbSetError(103);
  2102. {$ENDIF}
  2103.       with DbVars.ActiveNode^.DBInfo do
  2104.       begin
  2105.          freemem(WrkSpc,DbGetRecLen);
  2106.          WrkSpc := nil;
  2107.          if NdxSpc <> nil then
  2108.          begin
  2109.             freemem(NdxSpc,NdxFldLen);
  2110.             NdxSpc := nil;
  2111.             freemem(bakNdxSpc,NdxFldLen);
  2112.             BakNdxSpc := nil;
  2113.          end;
  2114.          with DbVars.ActiveNode^.DBInfo do
  2115.          begin
  2116.             if DFOpen then
  2117.             begin
  2118.                DFOpen := false;
  2119.                {$I-} close(DBFAlias); {$I+}
  2120.                if (IOResult <> 0) then
  2121.                   DbSetError(903); {close failure}
  2122.             end;
  2123.             if indexField > 0 then
  2124.             begin
  2125.                indexField := 0;
  2126.                ReleaseAllPages(NDXName);
  2127.                {$I-} close(NDXAlias); {$I+}
  2128.                if (IOResult <> 0) then
  2129.                   DbSetError(904); {close failure}
  2130.             end;
  2131.          end;
  2132.          freeMem(pField,sizeof(pField^));
  2133.          freeMem(pHead,sizeof(pHead^));
  2134.          _SLLDestroy(FldInfo);
  2135.          if MemoIsIncluded then
  2136.             freemem(pMemo,sizeof(pMemo^));
  2137.          if not DbVars.ClosingAll and ( Handle = DbVars.DBsOpen ) then
  2138.          begin
  2139.             while not DbVars.ActiveNode^.DBInfo.DFOpen and
  2140.                 ( DbVars.DBsOpen > 0 ) do
  2141.             begin
  2142.                freemem(DbVars.ActiveNode,sizeof(DbVars.ActiveNode^));
  2143.                if DbVars.ActiveNode <> DbVars.StartNode then
  2144.                begin
  2145.                   SetToPrevNode(DbVars.ActiveNode);
  2146.                   DbVars.ActiveNode^.NextPtr := nil;
  2147.                end;
  2148.                dec(DbVars.DBsOpen);
  2149.             end;
  2150.             if DbVars.DBsOpen = 0 then
  2151.             begin
  2152.                DbVars.StartNode := nil;
  2153.                DbVars.ActiveNode := nil;
  2154.             end;
  2155.          end;
  2156.       end;
  2157.    end;
  2158. end; { DbCloseDataBase }
  2159.  
  2160. procedure DbCloseAllDatabases;
  2161. {}
  2162. var Temp1,Temp2: DBListNodePtr;
  2163.     Count: integer;
  2164. begin
  2165.    with DbVars do
  2166.    begin
  2167.       if DBsOpen > 0 then
  2168.       begin
  2169.          ClosingAll := true;
  2170.          Count := 1;
  2171.          Temp1 := StartNode;
  2172.          while Temp1 <> nil do
  2173.          begin
  2174.             Temp2 := Temp1^.NextPtr;
  2175.             if Temp1^.DBInfo.DFOpen then
  2176.                DbCloseDatabase(Count);
  2177.             inc(Count);
  2178.             freemem(Temp1,sizeof(Temp1^));
  2179.             Temp1 := Temp2;
  2180.          end;
  2181.          ClosingAll := false;
  2182.       end;
  2183.       StartNode := nil;
  2184.       ActiveNode := nil;
  2185.    end;
  2186. end; { DbCloseAllDatabases }
  2187.  
  2188. function DbReadStructure: integer;
  2189. {}
  2190. var I: integer;
  2191.     HdrTerminator: byte;
  2192. begin
  2193.    DbReadStructure := 1;  { failure }
  2194.    with DbVars.ActiveNode^.DBInfo do
  2195.    begin
  2196.       {$I-} seek(DBFAlias,0); {$I+}    { Move ptr to TOF }
  2197.       if IOResult <> 0 then
  2198.          DbSetError(1202) { seek error }
  2199.       else
  2200.       begin
  2201.          { read header }
  2202.          blockread(DBFAlias, pHead^, sizeof(pHead^), DbVars.Actual);
  2203.          if DbVars.Actual <> sizeof(pHead^) then
  2204.             DbSetError(1102) { read error }
  2205.          else
  2206.          begin
  2207.             if ((pHead^.VersionNumber  AND 7) <> $03) then
  2208.                DBSetError(1010) { Not a valid dBase File, may be corrupt }
  2209.             else
  2210.             begin
  2211.                if (pHead^.VersionNumber = $83) then
  2212.                begin
  2213.                   MemoIsIncluded := true;
  2214.                   getmem(pMemo,sizeof(pMemo^));
  2215.                end;
  2216.                if ( DbTotalFields > 0 ) then
  2217.                begin
  2218.                   InitSLL(FldInfo);
  2219.                   for I := 1 to DbTotalFields do
  2220.                   begin
  2221.                      blockread(DBFAlias,pField^,sizeof(pField^),DbVars.Actual);
  2222.                      if DbVars.Actual <> sizeof(pField^) then
  2223.                         DbSetError(1103) { Unable to read field info while readinf structure }
  2224.                      else if (_SLLAdd(FldInfo,pField^,sizeof(pField^)) <> 0) then
  2225.                         DbSetError(1025); { error creating field list }
  2226.                   end;
  2227.                end;
  2228.                { Last Header Byte }
  2229.                blockread(DBFAlias,HdrTerminator,1,DbVars.Actual);
  2230.                if DbVars.Actual <> 1 then
  2231.                   DbSetError(1104) { Unable to read header terminator }
  2232.                else if HdrTerminator <> EOH then
  2233.                   DBSetError(1010)  {File may be corrupted}
  2234.                else
  2235.                   DbReadStructure := 0; {Structure OK}
  2236.             end;
  2237.          end;
  2238.       end;
  2239.    end;
  2240. end; { DbReadStructure }
  2241.  
  2242. function DbOpenDataFile(DBFile: PathStr): integer;
  2243. {internal use only - Use DbOpenDataSet externally}
  2244. begin
  2245. {$IFDEF CHECK}
  2246.    if DBVARS.ActiveNode = nil then
  2247.       DbSetError(103);
  2248. {$ENDIF}
  2249.    with DbVars.ActiveNode^.DBInfo do
  2250.    begin
  2251.       DbOpenDataFile := 1;  { failure }
  2252.       if not Exist(DBFile) then
  2253.          DBSetError(1021) { File not found }
  2254.       else
  2255.       begin
  2256.          assign(DBFAlias, DBFile);
  2257.          {$I-} reset(DBFAlias,1); {$I+}       { Set record length to 1 }
  2258.          DFOpen := (IOResult = 0);
  2259.          if not DFOpen then
  2260.             DbSetError(1201) { Unable to open dbf file during OpenDataFile }
  2261.          else
  2262.             DbOpenDataFile := 0; { success }
  2263.       end;
  2264.    end;
  2265. end; { DbOpenDataFile }
  2266.  
  2267. procedure DbOpenIndexFile;
  2268. {internal use only - Use DbOpenDataSet externally}
  2269. var ECode: integer;
  2270. begin
  2271. {$IFDEF CHECK}
  2272.    if DBVARS.ActiveNode = nil then
  2273.       DbSetError(103)
  2274.    else
  2275. {$ENDIF}
  2276.    with DbVars.ActiveNode^.DBInfo do
  2277.    begin
  2278.       if not Exist(NDXName) then
  2279.          IndexField := 0
  2280.       else
  2281.       begin
  2282.          assign(NDXAlias, NDXName);
  2283.          {$I-} reset(NDXAlias,PAGESIZE);
  2284.          ECode := IOResult; {$I+}
  2285.          if ECode <> 0 then
  2286.             DbSetError(1251) { Unable to reset index while opening }
  2287.          else
  2288.          begin
  2289.             IndexField := GetIndexedField(NDXName,NDXAlias);
  2290.             NdxFldLen := DbGetFldLength(IndexField);
  2291.             IndexUpperCase := GetUpperCaseFlag(NdxName,NdxAlias);
  2292.             InitializeFindRecord; { ensure Find Problems don't occur }
  2293.             if Ecode <> 0 then
  2294.                Ecode := 2000
  2295.             else if NdxValidate(true) <> 0 then
  2296.                Ecode := 2001;
  2297.             { this doesn't need to be called if ECode is 0 ??????}
  2298.             DBSetError(Ecode);
  2299.             if (Ecode = 0) and (NdxSpc = nil) then
  2300.                AllocateNdxSpc;
  2301.          end;
  2302.       end;
  2303.    end;
  2304. end; { DbOpenIndexFile }
  2305.  
  2306. function DbOpenMemoFile: integer;
  2307. {internal use only - Use DbOpenDataSet externally}
  2308. begin
  2309. {$IFDEF CHECK}
  2310.    if DBVARS.ActiveNode = nil then
  2311.       DbSetError(103);
  2312. {$ENDIF}
  2313.    with DbVars.ActiveNode^.DBInfo do
  2314.    begin
  2315.       DbOpenMemoFile := 1;  { failure }
  2316.       if not Exist(DBTName) then
  2317.          DbBuildMemoFile(DBTName);
  2318.       assign(DBTAlias,DBTName);
  2319.       {$I-} reset(DBTAlias,1); {$I+}
  2320.       if IOResult <> 0 then
  2321.          DbSetError(1036)  { Error reseting dbt file to access memo }
  2322.       else
  2323.       with DbVars.ActiveNode^.DBInfo.pMemo^ do
  2324.       begin
  2325.          blockread(DBTAlias,NextMemoRec,sizeof(NextMemoRec),DbVars.Actual);
  2326.          if DbVars.Actual <> sizeof(NextMemoRec) then
  2327.             DbSetError(1087) {}
  2328.          else
  2329.          begin
  2330.             if (FileSize(DbtAlias) div MemoPageSize) = pred(NextMemoRec) then
  2331.             begin
  2332.                LastMemoRec := pred(NextMemoRec);
  2333.                DbOpenMemoFile := 0;
  2334.             end else
  2335.                DbSetError(1035); { DBT corrupt }
  2336.          end;
  2337.          {$I-} close(DBTAlias); {$I+}
  2338.          if (IOResult <> 0) then
  2339.             DbSetError(905); {close failure}
  2340.       end;
  2341.    end;
  2342. end; { DbOpenMemoFile }
  2343.  
  2344. procedure SetFileNames(DBFile: pathstr);
  2345. {requirement of this unit}
  2346. begin
  2347. {$IFDEF CHECK}
  2348.    if DBVARS.ActiveNode = nil then
  2349.       DbSetError(103);
  2350. {$ENDIF}
  2351.    with DbVars.ActiveNode^.DBInfo do
  2352.    begin
  2353.       DBPath := SlashedDirectory(FIleDirectory(DBFile)); {extract pathname}
  2354.       DBFile := FileName(DBFile); {extract filename}
  2355.       DBFName := DBFile+ DFX;  {make DBF, IDX, and MFX file names the same}
  2356.       NDXName := DBFile+ IFX;
  2357.       DBTName := DBFile+ MFX;
  2358.    end;
  2359. end; { SetFileNames }
  2360.  
  2361. function DbOpenDataSet( DBFile: pathstr ): integer;
  2362. {  DbOpenDataSet returns the Handle of the database set (positive values)
  2363.    or 0 (zero) if the database failed to open. Error codes may be found
  2364.    in DbLastError.
  2365. }
  2366. var
  2367.     TmpFieldName: string[11];
  2368.     Handle: integer;
  2369. begin
  2370.    Handle := DbInitDatabase;  {returns unique handle}
  2371.    if Handle = 0 then
  2372.       DbOpenDataSet := 0
  2373.    else
  2374.    begin
  2375. {$IFDEF CHECK}
  2376.    if DBVARS.ActiveNode = nil then
  2377.       DbSetError(103);
  2378. {$ENDIF}
  2379.       with DbVars.ActiveNode^.DBInfo do
  2380.       begin
  2381.          SetFileNames(DBFile);
  2382.          {Open files}
  2383.          if ( DbOpenDataFile(DBPath + DBFName) = 0) and (DbReadStructure = 0) then
  2384.          begin
  2385.             DbOpenDataSet := Handle;
  2386.             getmem(WrkSpc,DbGetRecLen);
  2387.             { serves no purpose, just a bit of clean up }
  2388.             fillchar(pHead^.Reserved,sizeof(pHead^.Reserved),#0);
  2389.             fillchar(pField^.Reserved1,sizeof(pField^.Reserved1),#0);
  2390.             fillchar(pField^.Reserved2,sizeof(pField^.Reserved2),#0);
  2391.             DbOpenIndexFile;
  2392.             if MemoIsIncluded then
  2393.                MFOpen := DbOpenMemoFile = 0;
  2394.          end
  2395.          else
  2396.             DbOpenDataSet := 0;
  2397.       end;
  2398.    end;
  2399. end; { DbOpenDataSet }
  2400.  
  2401. procedure SetShowNdxProgress(Proc: ShowNdxProgressProc);
  2402. {}
  2403. begin
  2404.    DbVars.ShowNdxProgress := Proc;
  2405. end;
  2406.  
  2407.               {*********************************************}
  2408.               {**  U N I T   I N I T I A L I Z A T I O N  **}
  2409.               {*********************************************}
  2410.  
  2411. procedure DbDefaultSettings;
  2412. {}
  2413. begin
  2414.   with DbVars do
  2415.   begin
  2416.      DbfCFld := 'C';  { Character field }
  2417.      DbfNFld := 'N';  { Numeric field }
  2418.      DbfLFld := 'L';  { Logical field }
  2419.      DbfDFld := 'D';  { Date field }
  2420.      DbfMFld := 'M';  { Memo field }
  2421.      FullStrings := false;
  2422.      ShowNdxProgress := NoProgressHook;
  2423.   end;
  2424. end; { DbDefaultSettings }
  2425.  
  2426. procedure GoldDBInit;
  2427. {}
  2428. begin
  2429.   with DbVars do
  2430.   begin
  2431.     Packing := false;
  2432.     FldLstIsActive := false;
  2433.     ClosingAll := false;
  2434.     HasMemo := false;
  2435.     StartNode := nil;
  2436.     ActiveNode := nil;
  2437.     DBsOpen := 0;
  2438.     LastECode := 0;
  2439.     EMsgFunc := DbEMsg;
  2440.     Actual := 0;
  2441.   end;
  2442.   DbDefaultSettings;
  2443.   NdxInit;
  2444. end; {GoldDBInit}
  2445.  
  2446. begin
  2447.   GoldDBInit;
  2448. end.
  2449.